diff --git a/base/modules/psb_blacs_mod.f90 b/base/modules/psb_blacs_mod.f90 deleted file mode 100644 index d41db62d..00000000 --- a/base/modules/psb_blacs_mod.f90 +++ /dev/null @@ -1,4689 +0,0 @@ -module psb_blacs_mod - use psb_const_mod - - interface gebs2d - module procedure igebs2ds, igebs2dv, igebs2dm,& - & dgebs2ds, dgebs2dv, dgebs2dm,& - & zgebs2ds, zgebs2dv, zgebs2dm,& - & sgebs2ds, sgebs2dv, sgebs2dm,& - & cgebs2ds, cgebs2dv, cgebs2dm - end interface - - interface gebr2d - module procedure igebr2ds, igebr2dv, igebr2dm,& - & dgebr2ds, dgebr2dv, dgebr2dm,& - & zgebr2ds, zgebr2dv, zgebr2dm,& - & sgebr2ds, sgebr2dv, sgebr2dm,& - & cgebr2ds, cgebr2dv, cgebr2dm - - end interface - - interface gesd2d - module procedure igesd2ds, igesd2dv, igesd2dm,& - & dgesd2ds, dgesd2dv, dgesd2dm,& - & zgesd2ds, zgesd2dv, zgesd2dm,& - & sgesd2ds, sgesd2dv, sgesd2dm,& - & cgesd2ds, cgesd2dv, cgesd2dm - end interface - - interface gerv2d - module procedure igerv2ds, igerv2dv, igerv2dm,& - & dgerv2ds, dgerv2dv, dgerv2dm,& - & zgerv2ds, zgerv2dv, zgerv2dm,& - & sgerv2ds, sgerv2dv, sgerv2dm,& - & cgerv2ds, cgerv2dv, cgerv2dm - end interface - - interface gsum2d - module procedure igsum2ds, igsum2dv, igsum2dm,& - & dgsum2ds, dgsum2dv, dgsum2dm,& - & zgsum2ds, zgsum2dv, zgsum2dm,& - & sgsum2ds, sgsum2dv, sgsum2dm,& - & cgsum2ds, cgsum2dv, cgsum2dm - end interface - - interface gamx2d - module procedure igamx2ds, igamx2dv, igamx2dm,& - & dgamx2ds, dgamx2dv, dgamx2dm,& - & zgamx2ds, zgamx2dv, zgamx2dm,& - & sgamx2ds, sgamx2dv, sgamx2dm,& - & cgamx2ds, cgamx2dv, cgamx2dm - end interface - - - interface gamn2d - module procedure igamn2ds, igamn2dv, igamn2dm,& - & dgamn2ds, dgamn2dv, dgamn2dm,& - & zgamn2ds, zgamn2dv, zgamn2dm,& - & sgamn2ds, sgamn2dv, sgamn2dm,& - & cgamn2ds, cgamn2dv, cgamn2dm - end interface -contains - - - - subroutine igebs2ds(ictxt,scope,dat,top) - integer, intent(in) :: ictxt,dat - character, intent(in) :: scope - character, intent(in), optional :: top - - character :: top_ - - interface - subroutine igebs2d(ictxt,scope,top,m,n,v,ld) - integer, intent(in) :: ictxt,m,n,ld - integer, intent(in) :: v - character, intent(in) :: scope, top - end subroutine igebs2d - end interface - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - - call igebs2d(ictxt,scope,top_,1,1,dat,1) - - end subroutine igebs2ds - - subroutine igebs2dv(ictxt,scope,dat,top) - integer, intent(in) :: ictxt,dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - - - interface - subroutine igebs2d(ictxt,scope,top,m,n,v,ld) - integer, intent(in) :: ictxt,m,n,ld - integer, intent(in) :: v(*) - character, intent(in) :: scope, top - end subroutine igebs2d - end interface - - character :: top_ - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - - call igebs2d(ictxt,scope,top_,size(dat,1),1,dat,size(dat,1)) - - end subroutine igebs2dv - - subroutine igebs2dm(ictxt,scope,dat,top) - integer, intent(in) :: ictxt,dat(:,:) - character, intent(in) :: scope - character, intent(in), optional :: top - - interface - subroutine igebs2d(ictxt,scope,top,m,n,v,ld) - integer, intent(in) :: ictxt,m,n,ld - integer, intent(in) :: v(ld,*) - character, intent(in) :: scope, top - end subroutine igebs2d - end interface - character :: top_ - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - - call igebs2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1)) - - end subroutine igebs2dm - - - - subroutine dgebs2ds(ictxt,scope,dat,top) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(in) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - - interface - subroutine dgebs2d(ictxt,scope,top,m,n,v,ld) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(in) :: v - character, intent(in) :: scope, top - end subroutine dgebs2d - end interface - character :: top_ - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - - call dgebs2d(ictxt,scope,top_,1,1,dat,1) - - end subroutine dgebs2ds - - subroutine dgebs2dv(ictxt,scope,dat,top) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(in) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - - interface - subroutine dgebs2d(ictxt,scope,top,m,n,v,ld) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(in) :: v(*) - character, intent(in) :: scope, top - end subroutine dgebs2d - end interface - - character :: top_ - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - - call dgebs2d(ictxt,scope,top_,size(dat),1,dat,size(dat)) - - end subroutine dgebs2dv - - subroutine dgebs2dm(ictxt,scope,dat,top) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(in) :: dat(:,:) - - character, intent(in) :: scope - character, intent(in), optional :: top - - interface - subroutine dgebs2d(ictxt,scope,top,m,n,v,ld) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(in) :: v(ld,*) - character, intent(in) :: scope, top - end subroutine dgebs2d - end interface - - character :: top_ - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - - call dgebs2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1)) - - end subroutine dgebs2dm - - - subroutine sgebs2ds(ictxt,scope,dat,top) - integer, intent(in) :: ictxt - real(psb_spk_), intent(in) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - - interface - subroutine sgebs2d(ictxt,scope,top,m,n,v,ld) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_spk_), intent(in) :: v - character, intent(in) :: scope, top - end subroutine sgebs2d - end interface - character :: top_ - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - - call sgebs2d(ictxt,scope,top_,1,1,dat,1) - - end subroutine sgebs2ds - - subroutine sgebs2dv(ictxt,scope,dat,top) - integer, intent(in) :: ictxt - real(psb_spk_), intent(in) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - - interface - subroutine sgebs2d(ictxt,scope,top,m,n,v,ld) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_spk_), intent(in) :: v(*) - character, intent(in) :: scope, top - end subroutine sgebs2d - end interface - - character :: top_ - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - - call sgebs2d(ictxt,scope,top_,size(dat),1,dat,size(dat)) - - end subroutine sgebs2dv - - subroutine sgebs2dm(ictxt,scope,dat,top) - integer, intent(in) :: ictxt - real(psb_spk_), intent(in) :: dat(:,:) - - character, intent(in) :: scope - character, intent(in), optional :: top - - interface - subroutine sgebs2d(ictxt,scope,top,m,n,v,ld) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_spk_), intent(in) :: v(ld,*) - character, intent(in) :: scope, top - end subroutine sgebs2d - end interface - - character :: top_ - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - - call sgebs2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1)) - - end subroutine sgebs2dm - - - subroutine zgebs2ds(ictxt,scope,dat,top) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(in) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - - interface - subroutine zgebs2d(ictxt,scope,top,m,n,v,ld) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(in) :: v - character, intent(in) :: scope, top - end subroutine zgebs2d - end interface - character :: top_ - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - - call zgebs2d(ictxt,scope,top_,1,1,dat,1) - - end subroutine zgebs2ds - - subroutine zgebs2dv(ictxt,scope,dat,top) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(in) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - - interface - subroutine zgebs2d(ictxt,scope,top,m,n,v,ld) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(in) :: v(*) - character, intent(in) :: scope, top - end subroutine zgebs2d - end interface - - character :: top_ - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - - call zgebs2d(ictxt,scope,top_,size(dat),1,dat,size(dat)) - - end subroutine zgebs2dv - - subroutine zgebs2dm(ictxt,scope,dat,top) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(in) :: dat(:,:) - - character, intent(in) :: scope - character, intent(in), optional :: top - - interface - subroutine zgebs2d(ictxt,scope,top,m,n,v,ld) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(in) :: v(ld,*) - character, intent(in) :: scope, top - end subroutine zgebs2d - end interface - - character :: top_ - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - - call zgebs2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1)) - - end subroutine zgebs2dm - - subroutine cgebs2ds(ictxt,scope,dat,top) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(in) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - - interface - subroutine cgebs2d(ictxt,scope,top,m,n,v,ld) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_spk_), intent(in) :: v - character, intent(in) :: scope, top - end subroutine cgebs2d - end interface - character :: top_ - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - - call cgebs2d(ictxt,scope,top_,1,1,dat,1) - - end subroutine cgebs2ds - - subroutine cgebs2dv(ictxt,scope,dat,top) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(in) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - - interface - subroutine cgebs2d(ictxt,scope,top,m,n,v,ld) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_spk_), intent(in) :: v(*) - character, intent(in) :: scope, top - end subroutine cgebs2d - end interface - - character :: top_ - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - - call cgebs2d(ictxt,scope,top_,size(dat),1,dat,size(dat)) - - end subroutine cgebs2dv - - subroutine cgebs2dm(ictxt,scope,dat,top) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(in) :: dat(:,:) - - character, intent(in) :: scope - character, intent(in), optional :: top - - interface - subroutine cgebs2d(ictxt,scope,top,m,n,v,ld) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_spk_), intent(in) :: v(ld,*) - character, intent(in) :: scope, top - end subroutine cgebs2d - end interface - - character :: top_ - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - - call cgebs2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1)) - - end subroutine cgebs2dm - - - - - - subroutine dgebr2ds(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine dgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine dgebr2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = 0 - case('C','c') - rrt_ = 0 - crt_ = mycol - case('A','a') - rrt_ = 0 - crt_ = 0 - case default - rrt_ = 0 - crt_ = 0 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call dgebr2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) - - end subroutine dgebr2ds - - subroutine dgebr2dv(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine dgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine dgebr2d - end interface - - character :: top_ - integer :: nrows,ncols,myrow,mycol - integer :: rrt_, crt_ - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = 0 - case('C','c') - rrt_ = 0 - crt_ = mycol - case('A','a') - rrt_ = 0 - crt_ = 0 - case default - rrt_ = 0 - crt_ = 0 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call dgebr2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) - - end subroutine dgebr2dv - - subroutine dgebr2dm(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine dgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v(ld,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine dgebr2d - end interface - - character :: top_ - integer :: nrows,ncols,myrow,mycol - integer :: rrt_, crt_ - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = 0 - case('C','c') - rrt_ = 0 - crt_ = mycol - case('A','a') - rrt_ = 0 - crt_ = 0 - case default - rrt_ = 0 - crt_ = 0 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call dgebr2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) - - end subroutine dgebr2dm - - - subroutine sgebr2ds(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine sgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_spk_), intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine sgebr2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = 0 - case('C','c') - rrt_ = 0 - crt_ = mycol - case('A','a') - rrt_ = 0 - crt_ = 0 - case default - rrt_ = 0 - crt_ = 0 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call sgebr2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) - - end subroutine sgebr2ds - - subroutine sgebr2dv(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine sgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_spk_), intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine sgebr2d - end interface - - character :: top_ - integer :: nrows,ncols,myrow,mycol - integer :: rrt_, crt_ - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = 0 - case('C','c') - rrt_ = 0 - crt_ = mycol - case('A','a') - rrt_ = 0 - crt_ = 0 - case default - rrt_ = 0 - crt_ = 0 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call sgebr2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) - - end subroutine sgebr2dv - - subroutine sgebr2dm(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine sgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_spk_), intent(inout) :: v(ld,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine sgebr2d - end interface - - character :: top_ - integer :: nrows,ncols,myrow,mycol - integer :: rrt_, crt_ - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = 0 - case('C','c') - rrt_ = 0 - crt_ = mycol - case('A','a') - rrt_ = 0 - crt_ = 0 - case default - rrt_ = 0 - crt_ = 0 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call sgebr2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) - - end subroutine sgebr2dm - - - subroutine zgebr2ds(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine zgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine zgebr2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = 0 - case('C','c') - rrt_ = 0 - crt_ = mycol - case('A','a') - rrt_ = 0 - crt_ = 0 - case default - rrt_ = 0 - crt_ = 0 - end select - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call zgebr2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) - - end subroutine zgebr2ds - - subroutine zgebr2dv(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine zgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine zgebr2d - end interface - - character :: top_ - integer :: nrows,ncols,myrow,mycol - integer :: rrt_, crt_ - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = 0 - case('C','c') - rrt_ = 0 - crt_ = mycol - case('A','a') - rrt_ = 0 - crt_ = 0 - case default - rrt_ = 0 - crt_ = 0 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call zgebr2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) - - end subroutine zgebr2dv - - subroutine zgebr2dm(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine zgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v(ld,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine zgebr2d - end interface - - character :: top_ - integer :: nrows,ncols,myrow,mycol - integer :: rrt_, crt_ - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = 0 - case('C','c') - rrt_ = 0 - crt_ = mycol - case('A','a') - rrt_ = 0 - crt_ = 0 - case default - rrt_ = 0 - crt_ = 0 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call zgebr2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) - - end subroutine zgebr2dm - - subroutine cgebr2ds(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine cgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_spk_), intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine cgebr2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = 0 - case('C','c') - rrt_ = 0 - crt_ = mycol - case('A','a') - rrt_ = 0 - crt_ = 0 - case default - rrt_ = 0 - crt_ = 0 - end select - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call cgebr2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) - - end subroutine cgebr2ds - - subroutine cgebr2dv(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine cgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_spk_), intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine cgebr2d - end interface - - character :: top_ - integer :: nrows,ncols,myrow,mycol - integer :: rrt_, crt_ - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = 0 - case('C','c') - rrt_ = 0 - crt_ = mycol - case('A','a') - rrt_ = 0 - crt_ = 0 - case default - rrt_ = 0 - crt_ = 0 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call cgebr2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) - - end subroutine cgebr2dv - - subroutine cgebr2dm(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:,:) - - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine cgebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_spk_), intent(inout) :: v(ld,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine cgebr2d - end interface - - character :: top_ - integer :: nrows,ncols,myrow,mycol - integer :: rrt_, crt_ - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = 0 - case('C','c') - rrt_ = 0 - crt_ = mycol - case('A','a') - rrt_ = 0 - crt_ = 0 - case default - rrt_ = 0 - crt_ = 0 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call cgebr2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) - - end subroutine cgebr2dm - - - - subroutine igebr2ds(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine igebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine igebr2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = 0 - case('C','c') - rrt_ = 0 - crt_ = mycol - case('A','a') - rrt_ = 0 - crt_ = 0 - case default - rrt_ = 0 - crt_ = 0 - end select - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call igebr2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) - - end subroutine igebr2ds - - subroutine igebr2dv(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine igebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine igebr2d - end interface - - character :: top_ - integer :: nrows,ncols,myrow,mycol - integer :: rrt_, crt_ - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = 0 - case('C','c') - rrt_ = 0 - crt_ = mycol - case('A','a') - rrt_ = 0 - crt_ = 0 - case default - rrt_ = 0 - crt_ = 0 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call igebr2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) - - end subroutine igebr2dv - - subroutine igebr2dm(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:,:) - - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine igebr2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v(ld,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine igebr2d - end interface - - character :: top_ - integer :: nrows,ncols,myrow,mycol - integer :: rrt_, crt_ - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = 0 - case('C','c') - rrt_ = 0 - crt_ = mycol - case('A','a') - rrt_ = 0 - crt_ = 0 - case default - rrt_ = 0 - crt_ = 0 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call igebr2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) - - end subroutine igebr2dm - - - - subroutine sgesd2ds(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - real(psb_spk_), intent(in) :: dat - integer, intent(in) :: rdst,cdst - - interface - subroutine sgesd2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_spk_), intent(in) :: v - integer, intent(in) :: rd,cd - end subroutine sgesd2d - end interface - - call sgesd2d(ictxt,1,1,dat,1,rdst,cdst) - - end subroutine sgesd2ds - - - subroutine sgesd2dv(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - real(psb_spk_), intent(in) :: dat(:) - integer, intent(in) :: rdst,cdst - - interface - subroutine sgesd2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_spk_), intent(in) :: v(*) - integer, intent(in) :: rd,cd - end subroutine sgesd2d - end interface - - call sgesd2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) - - end subroutine sgesd2dv - - subroutine sgesd2dm(ictxt,dat,rdst,cdst,m) - integer, intent(in) :: ictxt - real(psb_spk_), intent(in) :: dat(:,:) - integer, intent(in) :: rdst,cdst - integer, intent(in), optional :: m - - integer :: m_ - interface - subroutine sgesd2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_spk_), intent(in) :: v(ld,*) - integer, intent(in) :: rd,cd - end subroutine sgesd2d - end interface - - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - endif - - call sgesd2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) - - end subroutine sgesd2dm - - - subroutine dgesd2ds(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(in) :: dat - integer, intent(in) :: rdst,cdst - - interface - subroutine dgesd2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(in) :: v - integer, intent(in) :: rd,cd - end subroutine dgesd2d - end interface - - call dgesd2d(ictxt,1,1,dat,1,rdst,cdst) - - end subroutine dgesd2ds - - - subroutine dgesd2dv(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(in) :: dat(:) - integer, intent(in) :: rdst,cdst - - interface - subroutine dgesd2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(in) :: v(*) - integer, intent(in) :: rd,cd - end subroutine dgesd2d - end interface - - call dgesd2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) - - end subroutine dgesd2dv - - subroutine dgesd2dm(ictxt,dat,rdst,cdst,m) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(in) :: dat(:,:) - integer, intent(in) :: rdst,cdst - integer, intent(in), optional :: m - - integer :: m_ - interface - subroutine dgesd2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(in) :: v(ld,*) - integer, intent(in) :: rd,cd - end subroutine dgesd2d - end interface - - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - endif - - call dgesd2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) - - end subroutine dgesd2dm - - - subroutine igesd2ds(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - integer, intent(in) :: dat - integer, intent(in) :: rdst,cdst - - interface - subroutine igesd2d(ictxt,m,n,v,ld,rd,cd) - integer, intent(in) :: ictxt,m,n,ld - integer, intent(in) :: v - integer, intent(in) :: rd,cd - end subroutine igesd2d - end interface - - call igesd2d(ictxt,1,1,dat,1,rdst,cdst) - - end subroutine igesd2ds - - - subroutine igesd2dv(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - integer, intent(in) :: dat(:) - integer, intent(in) :: rdst,cdst - - interface - subroutine igesd2d(ictxt,m,n,v,ld,rd,cd) - integer, intent(in) :: ictxt,m,n,ld - integer, intent(in) :: v(*) - integer, intent(in) :: rd,cd - end subroutine igesd2d - end interface - - call igesd2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) - - end subroutine igesd2dv - - subroutine igesd2dm(ictxt,dat,rdst,cdst,m) - integer, intent(in) :: ictxt - integer, intent(in) :: dat(:,:) - integer, intent(in) :: rdst,cdst - integer, intent(in), optional :: m - - integer :: m_ - - interface - subroutine igesd2d(ictxt,m,n,v,ld,rd,cd) - integer, intent(in) :: ictxt,m,n,ld - integer, intent(in) :: v(ld,*) - integer, intent(in) :: rd,cd - end subroutine igesd2d - end interface - - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - endif - - call igesd2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) - - end subroutine igesd2dm - - - - subroutine cgesd2ds(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(in) :: dat - integer, intent(in) :: rdst,cdst - - interface - subroutine cgesd2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_spk_), intent(in) :: v - integer, intent(in) :: rd,cd - end subroutine cgesd2d - end interface - - call cgesd2d(ictxt,1,1,dat,1,rdst,cdst) - - end subroutine cgesd2ds - - - subroutine cgesd2dv(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(in) :: dat(:) - integer, intent(in) :: rdst,cdst - - interface - subroutine cgesd2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_spk_), intent(in) :: v(*) - integer, intent(in) :: rd,cd - end subroutine cgesd2d - end interface - - call cgesd2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) - - end subroutine cgesd2dv - - subroutine cgesd2dm(ictxt,dat,rdst,cdst,m) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(in) :: dat(:,:) - integer, intent(in) :: rdst,cdst - integer, intent(in), optional :: m - - integer :: m_ - - interface - subroutine cgesd2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_spk_), intent(in) :: v(ld,*) - integer, intent(in) :: rd,cd - end subroutine cgesd2d - end interface - - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - endif - - call cgesd2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) - - end subroutine cgesd2dm - - - subroutine zgesd2ds(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(in) :: dat - integer, intent(in) :: rdst,cdst - - interface - subroutine zgesd2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(in) :: v - integer, intent(in) :: rd,cd - end subroutine zgesd2d - end interface - - call zgesd2d(ictxt,1,1,dat,1,rdst,cdst) - - end subroutine zgesd2ds - - - subroutine zgesd2dv(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(in) :: dat(:) - integer, intent(in) :: rdst,cdst - - interface - subroutine zgesd2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(in) :: v(*) - integer, intent(in) :: rd,cd - end subroutine zgesd2d - end interface - - call zgesd2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) - - end subroutine zgesd2dv - - subroutine zgesd2dm(ictxt,dat,rdst,cdst,m) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(in) :: dat(:,:) - integer, intent(in) :: rdst,cdst - integer, intent(in), optional :: m - - integer :: m_ - - interface - subroutine zgesd2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(in) :: v(ld,*) - integer, intent(in) :: rd,cd - end subroutine zgesd2d - end interface - - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - endif - - call zgesd2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) - - end subroutine zgesd2dm - - - - subroutine sgerv2ds(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer, intent(in) :: rdst,cdst - - interface - subroutine sgerv2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_spk_), intent(inout) :: v - integer, intent(in) :: rd,cd - end subroutine sgerv2d - end interface - - call sgerv2d(ictxt,1,1,dat,1,rdst,cdst) - - end subroutine sgerv2ds - - - subroutine sgerv2dv(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer, intent(in) :: rdst,cdst - - interface - subroutine sgerv2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_spk_), intent(inout) :: v(*) - integer, intent(in) :: rd,cd - end subroutine sgerv2d - end interface - - call sgerv2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) - - end subroutine sgerv2dv - - subroutine sgerv2dm(ictxt,dat,rdst,cdst,m) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer, intent(in) :: rdst,cdst - integer, intent(in), optional :: m - - integer :: m_ - - interface - subroutine sgerv2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_spk_), intent(inout) :: v(ld,*) - integer, intent(in) :: rd,cd - end subroutine sgerv2d - end interface - - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - endif - - call sgerv2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) - - end subroutine sgerv2dm - - subroutine dgerv2ds(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer, intent(in) :: rdst,cdst - - interface - subroutine dgerv2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v - integer, intent(in) :: rd,cd - end subroutine dgerv2d - end interface - - call dgerv2d(ictxt,1,1,dat,1,rdst,cdst) - - end subroutine dgerv2ds - - - subroutine dgerv2dv(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer, intent(in) :: rdst,cdst - - interface - subroutine dgerv2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v(*) - integer, intent(in) :: rd,cd - end subroutine dgerv2d - end interface - - call dgerv2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) - - end subroutine dgerv2dv - - subroutine dgerv2dm(ictxt,dat,rdst,cdst,m) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer, intent(in) :: rdst,cdst - integer, intent(in), optional :: m - - integer :: m_ - - interface - subroutine dgerv2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v(ld,*) - integer, intent(in) :: rd,cd - end subroutine dgerv2d - end interface - - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - endif - - call dgerv2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) - - end subroutine dgerv2dm - - - subroutine igerv2ds(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat - integer, intent(in) :: rdst,cdst - - interface - subroutine igerv2d(ictxt,m,n,v,ld,rd,cd) - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v - integer, intent(in) :: rd,cd - end subroutine igerv2d - end interface - - call igerv2d(ictxt,1,1,dat,1,rdst,cdst) - - end subroutine igerv2ds - - - subroutine igerv2dv(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:) - integer, intent(in) :: rdst,cdst - - interface - subroutine igerv2d(ictxt,m,n,v,ld,rd,cd) - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v(*) - integer, intent(in) :: rd,cd - end subroutine igerv2d - end interface - - call igerv2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) - - end subroutine igerv2dv - - subroutine igerv2dm(ictxt,dat,rdst,cdst,m) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:,:) - integer, intent(in) :: rdst,cdst - integer, intent(in), optional :: m - - integer :: m_ - - interface - subroutine igerv2d(ictxt,m,n,v,ld,rd,cd) - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v(ld,*) - integer, intent(in) :: rd,cd - end subroutine igerv2d - end interface - - - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - endif - - call igerv2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) - - end subroutine igerv2dm - - - - subroutine cgerv2ds(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat - integer, intent(in) :: rdst,cdst - - interface - subroutine cgerv2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_spk_), intent(inout) :: v - integer, intent(in) :: rd,cd - end subroutine cgerv2d - end interface - - call cgerv2d(ictxt,1,1,dat,1,rdst,cdst) - - end subroutine cgerv2ds - - - subroutine cgerv2dv(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:) - integer, intent(in) :: rdst,cdst - - interface - subroutine cgerv2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_spk_), intent(inout) :: v(*) - integer, intent(in) :: rd,cd - end subroutine cgerv2d - end interface - - call cgerv2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) - - end subroutine cgerv2dv - - subroutine cgerv2dm(ictxt,dat,rdst,cdst,m) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:,:) - integer, intent(in) :: rdst,cdst - integer, intent(in), optional :: m - - integer :: m_ - - interface - subroutine cgerv2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_spk_), intent(inout) :: v(ld,*) - integer, intent(in) :: rd,cd - end subroutine cgerv2d - end interface - - - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - endif - - call cgerv2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) - - end subroutine cgerv2dm - - subroutine zgerv2ds(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - integer, intent(in) :: rdst,cdst - - interface - subroutine zgerv2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v - integer, intent(in) :: rd,cd - end subroutine zgerv2d - end interface - - call zgerv2d(ictxt,1,1,dat,1,rdst,cdst) - - end subroutine zgerv2ds - - - subroutine zgerv2dv(ictxt,dat,rdst,cdst) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - integer, intent(in) :: rdst,cdst - - interface - subroutine zgerv2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v(*) - integer, intent(in) :: rd,cd - end subroutine zgerv2d - end interface - - call zgerv2d(ictxt,size(dat),1,dat,size(dat),rdst,cdst) - - end subroutine zgerv2dv - - subroutine zgerv2dm(ictxt,dat,rdst,cdst,m) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - integer, intent(in) :: rdst,cdst - integer, intent(in), optional :: m - - integer :: m_ - - interface - subroutine zgerv2d(ictxt,m,n,v,ld,rd,cd) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v(ld,*) - integer, intent(in) :: rd,cd - end subroutine zgerv2d - end interface - - - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - endif - - call zgerv2d(ictxt,m_,size(dat,2),dat,size(dat,1),rdst,cdst) - - end subroutine zgerv2dm - - - - subroutine sgsum2ds(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine sgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_spk_), intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine sgsum2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call sgsum2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) - - end subroutine sgsum2ds - - subroutine sgsum2dv(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine sgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_spk_), intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine sgsum2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call sgsum2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) - - end subroutine sgsum2dv - - subroutine sgsum2dm(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine sgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_spk_), intent(inout) :: v(ld,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine sgsum2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call sgsum2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) - - end subroutine sgsum2dm - - subroutine dgsum2ds(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine dgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine dgsum2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call dgsum2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) - - end subroutine dgsum2ds - - subroutine dgsum2dv(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine dgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine dgsum2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call dgsum2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) - - end subroutine dgsum2dv - - subroutine dgsum2dm(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine dgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v(ld,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine dgsum2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call dgsum2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) - - end subroutine dgsum2dm - - - - subroutine igsum2ds(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine igsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine igsum2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call igsum2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) - - end subroutine igsum2ds - - subroutine igsum2dv(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine igsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine igsum2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call igsum2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) - - end subroutine igsum2dv - - subroutine igsum2dm(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:,:) - - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine igsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v(ld,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine igsum2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call igsum2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) - - end subroutine igsum2dm - - - subroutine cgsum2ds(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine cgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_spk_), intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine cgsum2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call cgsum2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) - - end subroutine cgsum2ds - - subroutine cgsum2dv(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine cgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_spk_), intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine cgsum2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call cgsum2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) - - end subroutine cgsum2dv - - subroutine cgsum2dm(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:,:) - - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine cgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_spk_), intent(inout) :: v(ld,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine cgsum2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call cgsum2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) - - end subroutine cgsum2dm - - - subroutine zgsum2ds(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine zgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine zgsum2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call zgsum2d(ictxt,scope,top_,1,1,dat,1,rrt_,crt_) - - end subroutine zgsum2ds - - subroutine zgsum2dv(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine zgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine zgsum2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call zgsum2d(ictxt,scope,top_,size(dat),1,dat,size(dat),rrt_,crt_) - - end subroutine zgsum2dv - - subroutine zgsum2dm(ictxt,scope,dat,top,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine zgsum2d(ictxt,scope,top,m,n,v,ld,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v(ld,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine zgsum2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - call zgsum2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),rrt_,crt_) - - end subroutine zgsum2dm - - - subroutine sgamx2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - integer, intent(inout), optional :: ria,cia - - interface - subroutine sgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_spk_), intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine sgamx2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1),cia_(1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).or.present(cia)) then - call sgamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) - if (present(ria)) ria=ria_(1) - if (present(cia)) cia=cia_(1) - else - call sgamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) - endif - end subroutine sgamx2ds - - - subroutine sgamx2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(inout), optional :: ria(:),cia(:) - integer, intent(in), optional :: rrt,crt - - interface - subroutine sgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_spk_), intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine sgamx2d - end interface - - integer :: ldia_,ria_(1),cia_(1) - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call sgamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria,cia,min(size(ria),size(cia)),rrt_,crt_) - else - ldia_ = -1 - call sgamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine sgamx2dv - - subroutine sgamx2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - character, intent(in) :: scope - integer, intent(inout), optional :: ria(:,:),cia(:,:) - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine sgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld,ldia - real(psb_spk_), intent(inout) :: v(ld,*) - integer, intent(inout) :: ria(ldia,*),cia(ldia,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine sgamx2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1,1),cia_(1,1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call sgamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) - else - ldia_ = -1 - call sgamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine sgamx2dm - - - subroutine dgamx2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - integer, intent(inout), optional :: ria,cia - - interface - subroutine dgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine dgamx2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1),cia_(1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).or.present(cia)) then - call dgamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) - if (present(ria)) ria=ria_(1) - if (present(cia)) cia=cia_(1) - else - call dgamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) - endif - end subroutine dgamx2ds - - - subroutine dgamx2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(inout), optional :: ria(:),cia(:) - integer, intent(in), optional :: rrt,crt - - interface - subroutine dgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine dgamx2d - end interface - - integer :: ldia_,ria_(1),cia_(1) - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call dgamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria,cia,min(size(ria),size(cia)),rrt_,crt_) - else - ldia_ = -1 - call dgamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine dgamx2dv - - subroutine dgamx2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - character, intent(in) :: scope - integer, intent(inout), optional :: ria(:,:),cia(:,:) - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine dgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld,ldia - real(psb_dpk_), intent(inout) :: v(ld,*) - integer, intent(inout) :: ria(ldia,*),cia(ldia,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine dgamx2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1,1),cia_(1,1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call dgamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) - else - ldia_ = -1 - call dgamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine dgamx2dm - - - - subroutine igamx2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - integer, intent(inout), optional :: ria,cia - - interface - subroutine igamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine igamx2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1),cia_(1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).or.present(cia)) then - call igamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) - if (present(ria)) ria=ria_(1) - if (present(cia)) cia=cia_(1) - else - call igamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) - endif - end subroutine igamx2ds - - - subroutine igamx2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(inout), optional :: ria(:),cia(:) - integer, intent(in), optional :: rrt,crt - - interface - subroutine igamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine igamx2d - end interface - - integer :: ldia_,ria_(1),cia_(1) - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call igamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria,cia,min(size(ria),size(cia)),rrt_,crt_) - else - ldia_ = -1 - call igamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine igamx2dv - - subroutine igamx2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:,:) - character, intent(in) :: scope - integer, intent(inout), optional :: ria(:,:),cia(:,:) - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine igamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - integer, intent(in) :: ictxt,m,n,ld,ldia - integer, intent(inout) :: v(ld,*) - integer, intent(inout) :: ria(ldia,*),cia(ldia,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine igamx2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1,1),cia_(1,1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call igamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) - else - ldia_ = -1 - call igamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine igamx2dm - - - subroutine cgamx2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - integer, intent(inout), optional :: ria,cia - - interface - subroutine cgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_spk_), intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine cgamx2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1),cia_(1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).or.present(cia)) then - call cgamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) - if (present(ria)) ria=ria_(1) - if (present(cia)) cia=cia_(1) - else - call cgamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) - endif - end subroutine cgamx2ds - - - subroutine cgamx2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(inout), optional :: ria(:),cia(:) - integer, intent(in), optional :: rrt,crt - - interface - subroutine cgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_spk_), intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine cgamx2d - end interface - - integer :: ldia_,ria_(1),cia_(1) - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call cgamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria,cia,min(size(ria),size(cia)),rrt_,crt_) - else - ldia_ = -1 - call cgamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine cgamx2dv - - subroutine cgamx2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:,:) - character, intent(in) :: scope - integer, intent(inout), optional :: ria(:,:),cia(:,:) - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine cgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld,ldia - complex(psb_spk_), intent(inout) :: v(ld,*) - integer, intent(inout) :: ria(ldia,*),cia(ldia,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine cgamx2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1,1),cia_(1,1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call cgamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) - else - ldia_ = -1 - call cgamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine cgamx2dm - - - subroutine zgamx2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - integer, intent(inout), optional :: ria,cia - - interface - subroutine zgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine zgamx2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1),cia_(1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).or.present(cia)) then - call zgamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) - if (present(ria)) ria=ria_(1) - if (present(cia)) cia=cia_(1) - else - call zgamx2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) - endif - end subroutine zgamx2ds - - - subroutine zgamx2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(inout), optional :: ria(:),cia(:) - integer, intent(in), optional :: rrt,crt - - interface - subroutine zgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine zgamx2d - end interface - - integer :: ldia_,ria_(1),cia_(1) - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call zgamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria,cia,min(size(ria),size(cia)),rrt_,crt_) - else - ldia_ = -1 - call zgamx2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine zgamx2dv - - subroutine zgamx2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - character, intent(in) :: scope - integer, intent(inout), optional :: ria(:,:),cia(:,:) - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine zgamx2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld,ldia - complex(psb_dpk_), intent(inout) :: v(ld,*) - integer, intent(inout) :: ria(ldia,*),cia(ldia,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine zgamx2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1,1),cia_(1,1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call zgamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) - else - ldia_ = -1 - call zgamx2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine zgamx2dm - - - subroutine sgamn2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - integer, intent(inout), optional :: ria,cia - - interface - subroutine sgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_spk_), intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine sgamn2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1),cia_(1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).or.present(cia)) then - call sgamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) - if (present(ria)) ria=ria_(1) - if (present(cia)) cia=cia_(1) - else - call sgamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) - endif - end subroutine sgamn2ds - - - subroutine sgamn2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(inout), optional :: ria(:),cia(:) - integer, intent(in), optional :: rrt,crt - - interface - subroutine sgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_spk_), intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine sgamn2d - end interface - - integer :: ldia_,ria_(1),cia_(1) - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call sgamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria,cia,min(size(ria),size(cia)),rrt_,crt_) - else - ldia_ = -1 - call sgamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine sgamn2dv - - subroutine sgamn2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - character, intent(in) :: scope - integer, intent(inout), optional :: ria(:,:),cia(:,:) - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine sgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld,ldia - real(psb_spk_), intent(inout) :: v(ld,*) - integer, intent(inout) :: ria(ldia,*),cia(ldia,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine sgamn2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1,1),cia_(1,1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call sgamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) - else - ldia_ = -1 - call sgamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine sgamn2dm - - subroutine dgamn2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - integer, intent(inout), optional :: ria,cia - - interface - subroutine dgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine dgamn2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1),cia_(1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).or.present(cia)) then - call dgamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) - if (present(ria)) ria=ria_(1) - if (present(cia)) cia=cia_(1) - else - call dgamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) - endif - end subroutine dgamn2ds - - - subroutine dgamn2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(inout), optional :: ria(:),cia(:) - integer, intent(in), optional :: rrt,crt - - interface - subroutine dgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - real(psb_dpk_), intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine dgamn2d - end interface - - integer :: ldia_,ria_(1),cia_(1) - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call dgamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria,cia,min(size(ria),size(cia)),rrt_,crt_) - else - ldia_ = -1 - call dgamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine dgamn2dv - - subroutine dgamn2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - character, intent(in) :: scope - integer, intent(inout), optional :: ria(:,:),cia(:,:) - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine dgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld,ldia - real(psb_dpk_), intent(inout) :: v(ld,*) - integer, intent(inout) :: ria(ldia,*),cia(ldia,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine dgamn2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1,1),cia_(1,1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call dgamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) - else - ldia_ = -1 - call dgamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine dgamn2dm - - - subroutine igamn2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - integer, intent(inout), optional :: ria,cia - - interface - subroutine igamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine igamn2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1),cia_(1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).or.present(cia)) then - call igamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) - if (present(ria)) ria=ria_(1) - if (present(cia)) cia=cia_(1) - else - call igamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) - endif - end subroutine igamn2ds - - - subroutine igamn2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(inout), optional :: ria(:),cia(:) - integer, intent(in), optional :: rrt,crt - - interface - subroutine igamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - integer, intent(in) :: ictxt,m,n,ld - integer, intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine igamn2d - end interface - - integer :: ldia_,ria_(1),cia_(1) - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call igamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria,cia,min(size(ria),size(cia)),rrt_,crt_) - else - ldia_ = -1 - call igamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine igamn2dv - - subroutine igamn2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - integer, intent(inout) :: dat(:,:) - character, intent(in) :: scope - integer, intent(inout), optional :: ria(:,:),cia(:,:) - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine igamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - integer, intent(in) :: ictxt,m,n,ld,ldia - integer, intent(inout) :: v(ld,*) - integer, intent(inout) :: ria(ldia,*),cia(ldia,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine igamn2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1,1),cia_(1,1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call igamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) - else - ldia_ = -1 - call igamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine igamn2dm - - - subroutine cgamn2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - integer, intent(inout), optional :: ria,cia - - interface - subroutine cgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_spk_), intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine cgamn2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1),cia_(1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).or.present(cia)) then - call cgamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) - if (present(ria)) ria=ria_(1) - if (present(cia)) cia=cia_(1) - else - call cgamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) - endif - end subroutine cgamn2ds - - - subroutine cgamn2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(inout), optional :: ria(:),cia(:) - integer, intent(in), optional :: rrt,crt - - interface - subroutine cgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_spk_), intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine cgamn2d - end interface - - integer :: ldia_,ria_(1),cia_(1) - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call cgamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria,cia,min(size(ria),size(cia)),rrt_,crt_) - else - ldia_ = -1 - call cgamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine cgamn2dv - - subroutine cgamn2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:,:) - character, intent(in) :: scope - integer, intent(inout), optional :: ria(:,:),cia(:,:) - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine cgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld,ldia - complex(psb_spk_), intent(inout) :: v(ld,*) - integer, intent(inout) :: ria(ldia,*),cia(ldia,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine cgamn2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1,1),cia_(1,1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call cgamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) - else - ldia_ = -1 - call cgamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine cgamn2dm - - subroutine zgamn2ds(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - integer, intent(inout), optional :: ria,cia - - interface - subroutine zgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine zgamn2d - end interface - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1),cia_(1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).or.present(cia)) then - call zgamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,1,rrt_,crt_) - if (present(ria)) ria=ria_(1) - if (present(cia)) cia=cia_(1) - else - call zgamn2d(ictxt,scope,top_,1,1,dat,1,ria_,cia_,-1,rrt_,crt_) - endif - end subroutine zgamn2ds - - - subroutine zgamn2dv(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - character, intent(in) :: scope - character, intent(in), optional :: top - integer, intent(inout), optional :: ria(:),cia(:) - integer, intent(in), optional :: rrt,crt - - interface - subroutine zgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld - complex(psb_dpk_), intent(inout) :: v(*) - character, intent(in) :: scope, top - integer, intent(inout) :: ria(*),cia(*) - integer, intent(in) :: rrt,crt,ldia - end subroutine zgamn2d - end interface - - integer :: ldia_,ria_(1),cia_(1) - character :: top_ - integer :: rrt_, crt_ - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call zgamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria,cia,min(size(ria),size(cia)),rrt_,crt_) - else - ldia_ = -1 - call zgamn2d(ictxt,scope,top_,size(dat),1,dat,size(dat),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine zgamn2dv - - subroutine zgamn2dm(ictxt,scope,dat,top,ria,cia,rrt,crt) - integer, intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - character, intent(in) :: scope - integer, intent(inout), optional :: ria(:,:),cia(:,:) - character, intent(in), optional :: top - integer, intent(in), optional :: rrt,crt - - interface - subroutine zgamn2d(ictxt,scope,top,m,n,v,ld,ria,cia,ldia,rrt,crt) - use psb_const_mod - integer, intent(in) :: ictxt,m,n,ld,ldia - complex(psb_dpk_), intent(inout) :: v(ld,*) - integer, intent(inout) :: ria(ldia,*),cia(ldia,*) - character, intent(in) :: scope, top - integer, intent(in) :: rrt,crt - end subroutine zgamn2d - end interface - - character :: top_ - integer :: rrt_, crt_ - integer :: ldia_,ria_(1,1),cia_(1,1) - integer :: nrows,ncols,myrow,mycol - - - call blacs_gridinfo(ictxt,nrows,ncols,myrow,mycol) - select case(scope) - case('R','r') - rrt_ = myrow - crt_ = -1 - case('C','c') - rrt_ = -1 - crt_ = mycol - case('A','a') - rrt_ = -1 - crt_ = -1 - case default - rrt_ = -1 - crt_ = -1 - end select - - - if (present(top)) then - top_ = top - else - top_ = ' ' - endif - if (present(rrt)) then - rrt_ = rrt - endif - if (present(crt)) then - crt_ = crt - endif - - if (present(ria).and.present(cia)) then - call zgamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria,cia,min(size(ria,1),size(cia,1)),rrt_,crt_) - else - ldia_ = -1 - call zgamn2d(ictxt,scope,top_,size(dat,1),size(dat,2),dat,size(dat,1),& - & ria_,cia_,ldia_,rrt_,crt_) - end if - - end subroutine zgamn2dm - -end module psb_blacs_mod diff --git a/base/modules/psb_error_impl.F90 b/base/modules/psb_error_impl.F90 new file mode 100644 index 00000000..eea493cf --- /dev/null +++ b/base/modules/psb_error_impl.F90 @@ -0,0 +1,103 @@ +! checks wether an error has occurred on one of the porecesses in the execution pool +subroutine psb_errcomm(ictxt, err) + use psb_error_mod, psb_protect_name => psb_errcomm + use psb_penv_mod + integer, intent(in) :: ictxt + integer, intent(inout):: err + integer :: temp(2) + ! Cannot use psb_amx or otherwise we have a recursion in module usage +#if !defined(SERIAL_MPI) + call psb_amx(ictxt, err) +#endif +end subroutine psb_errcomm +! handles the occurence of an error in a serial routine +subroutine psb_serror() + use psb_error_mod!, psb_protect_name => psb_serror + + integer :: err_c + character(len=20) :: r_name + character(len=40) :: a_e_d + integer :: i_e_d(5) + + if(error_status > 0) then + if(verbosity_level > 1) then + + do while (psb_get_numerr() > izero) + write(0,'(50("="))') + call psb_errpop(err_c, r_name, i_e_d, a_e_d) + call psb_errmsg(err_c, r_name, i_e_d, a_e_d) + ! write(0,'(50("="))') + end do + + else + + call psb_errpop(err_c, r_name, i_e_d, a_e_d) + call psb_errmsg(err_c, r_name, i_e_d, a_e_d) + do while (psb_get_numerr() > 0) + call psb_errpop(err_c, r_name, i_e_d, a_e_d) + end do + end if + end if + +end subroutine psb_serror + + +! handles the occurence of an error in a parallel routine +subroutine psb_perror(ictxt) + use psb_error_mod!, psb_protect_name => psb_perror + use psb_penv_mod + + integer, intent(in) :: ictxt + integer :: err_c + character(len=20) :: r_name + character(len=40) :: a_e_d + integer :: i_e_d(5) + integer :: iam, np + +#if defined(SERIAL_MPI) + me = -1 +#else + call psb_info(ictxt,iam,np) +#endif + + + if(error_status > 0) then + if(verbosity_level > 1) then + + do while (psb_get_numerr() > izero) + write(0,'(50("="))') + call psb_errpop(err_c, r_name, i_e_d, a_e_d) + call psb_errmsg(err_c, r_name, i_e_d, a_e_d,me) + ! write(0,'(50("="))') + end do +#if defined(SERIAL_MPI) + stop +#else + call psb_abort(ictxt,-1) +#endif + else + + call psb_errpop(err_c, r_name, i_e_d, a_e_d) + call psb_errmsg(err_c, r_name, i_e_d, a_e_d,me) + do while (psb_get_numerr() > 0) + call psb_errpop(err_c, r_name, i_e_d, a_e_d) + end do +#if defined(SERIAL_MPI) + stop +#else + call psb_abort(ictxt,-1) +#endif + end if + end if + + if(error_status > izero) then +#if defined(SERIAL_MPI) + stop +#else + call psb_abort(ictxt,err_c) +#endif + end if + + +end subroutine psb_perror + diff --git a/base/modules/psi_bcast_mod.F90 b/base/modules/psi_bcast_mod.F90 new file mode 100644 index 00000000..ba86d352 --- /dev/null +++ b/base/modules/psi_bcast_mod.F90 @@ -0,0 +1,538 @@ + + +module psi_bcast_mod + use psb_const_mod + use psi_penv_mod + interface psb_bcast + module procedure psb_ibcasts, psb_ibcastv, psb_ibcastm,& + & psb_dbcasts, psb_dbcastv, psb_dbcastm,& + & psb_zbcasts, psb_zbcastv, psb_zbcastm,& + & psb_sbcasts, psb_sbcastv, psb_sbcastm,& + & psb_cbcasts, psb_cbcastv, psb_cbcastm,& + & psb_hbcasts, psb_hbcastv, psb_lbcasts, psb_lbcastv + end interface + +contains + + ! !!!!!!!!!!!!!!!!!!!!!! + ! + ! Broadcasts + ! + ! !!!!!!!!!!!!!!!!!!!!!! + + + subroutine psb_ibcasts(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer, intent(inout) :: dat + integer, intent(in), optional :: root + + integer :: iam, np, root_, info + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + call mpi_bcast(dat,1,psb_mpi_integer,root_,ictxt,info) +#endif + end subroutine psb_ibcasts + + subroutine psb_ibcastv(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer, intent(inout) :: dat(:) + integer, intent(in), optional :: root + + integer :: iam, np, root_, info +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + call mpi_bcast(dat,size(dat),psb_mpi_integer,root_,ictxt,info) +#endif + end subroutine psb_ibcastv + + subroutine psb_ibcastm(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer, intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + + integer :: iam, np, root_, info + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + call mpi_bcast(dat,size(dat),psb_mpi_integer,root_,ictxt,info) +#endif + end subroutine psb_ibcastm + + + subroutine psb_sbcasts(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer, intent(in), optional :: root + + integer :: iam, np, root_, info + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + call mpi_bcast(dat,1,mpi_real,root_,ictxt,info) +#endif + end subroutine psb_sbcasts + + + subroutine psb_sbcastv(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + + integer :: iam, np, root_, info + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + call mpi_bcast(dat,size(dat),mpi_real,root_,ictxt,info) + +#endif + end subroutine psb_sbcastv + + subroutine psb_sbcastm(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + + integer :: iam, np, root_, info + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + call mpi_bcast(dat,size(dat),mpi_real,root_,ictxt,info) + +#endif + end subroutine psb_sbcastm + + + subroutine psb_dbcasts(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + integer, intent(in), optional :: root + + integer :: iam, np, root_, info + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + call mpi_bcast(dat,1,mpi_double_precision,root_,ictxt,info) +#endif + end subroutine psb_dbcasts + + + subroutine psb_dbcastv(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + + integer :: iam, np, root_, info + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + call mpi_bcast(dat,size(dat),mpi_double_precision,root_,ictxt,info) +#endif + end subroutine psb_dbcastv + + subroutine psb_dbcastm(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + + integer :: iam, np, root_, info + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + call mpi_bcast(dat,size(dat),mpi_double_precision,root_,ictxt,info) +#endif + end subroutine psb_dbcastm + + subroutine psb_cbcasts(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat + integer, intent(in), optional :: root + + integer :: iam, np, root_, info + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + call mpi_bcast(dat,1,mpi_complex,root_,ictxt,info) +#endif + end subroutine psb_cbcasts + + subroutine psb_cbcastv(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + + integer :: iam, np, root_, info + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + call mpi_bcast(dat,size(dat),mpi_complex,root_,ictxt,info) +#endif + end subroutine psb_cbcastv + + subroutine psb_cbcastm(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + + integer :: iam, np, root_, info + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + call mpi_bcast(dat,size(dat),mpi_complex,root_,ictxt,info) +#endif + end subroutine psb_cbcastm + + subroutine psb_zbcasts(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat + integer, intent(in), optional :: root + + integer :: iam, np, root_, info + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + call mpi_bcast(dat,1,mpi_double_complex,root_,ictxt,info) +#endif + end subroutine psb_zbcasts + + subroutine psb_zbcastv(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + + integer :: iam, np, root_, info + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + call mpi_bcast(dat,size(dat),mpi_double_complex,root_,ictxt,info) +#endif + end subroutine psb_zbcastv + + subroutine psb_zbcastm(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + + integer :: iam, np, root_, info + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + call mpi_bcast(dat,size(dat),mpi_double_complex,root_,ictxt,info) +#endif + end subroutine psb_zbcastm + + + subroutine psb_hbcasts(ictxt,dat,root,length) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + character(len=*), intent(inout) :: dat + integer, intent(in), optional :: root,length + + integer :: iam, np, root_,length_,info + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + if (present(length)) then + length_ = length + else + length_ = len(dat) + endif + + call psb_info(ictxt,iam,np) + + call mpi_bcast(dat,length_,MPI_CHARACTER,root_,ictxt,info) +#endif + + end subroutine psb_hbcasts + + subroutine psb_hbcastv(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + character(len=*), intent(inout) :: dat(:) + integer, intent(in), optional :: root + + integer :: iam, np, root_,length_,info, size_ + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + length_ = len(dat) + size_ = size(dat) + + call psb_info(ictxt,iam,np) + + call mpi_bcast(dat,length_*size_,MPI_CHARACTER,root_,ictxt,info) +#endif + + end subroutine psb_hbcastv + + subroutine psb_lbcasts(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + logical, intent(inout) :: dat + integer, intent(in), optional :: root + + integer :: iam, np, root_,info + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + call mpi_bcast(dat,1,MPI_LOGICAL,root_,ictxt,info) +#endif + + end subroutine psb_lbcasts + + + subroutine psb_lbcastv(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + logical, intent(inout) :: dat(:) + integer, intent(in), optional :: root + + integer :: iam, np, root_,info + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + call mpi_bcast(dat,size(dat),MPI_LOGICAL,root_,ictxt,info) +#endif + + end subroutine psb_lbcastv + +end module psi_bcast_mod diff --git a/base/modules/psi_comm_buffers_mod.F90 b/base/modules/psi_comm_buffers_mod.F90 new file mode 100644 index 00000000..87fdf949 --- /dev/null +++ b/base/modules/psi_comm_buffers_mod.F90 @@ -0,0 +1,478 @@ +module psi_comm_buffers_mod + use psb_const_mod + + integer, private, parameter:: psb_int_type = 987543 + integer, private, parameter:: psb_real_type = psb_int_type + 1 + integer, private, parameter:: psb_double_type = psb_real_type + 1 + integer, private, parameter:: psb_complex_type = psb_double_type + 1 + integer, private, parameter:: psb_dcomplex_type = psb_complex_type + 1 + integer, private, parameter:: psb_logical_type = psb_dcomplex_type + 1 + integer, private, parameter:: psb_char_type = psb_logical_type + 1 + integer, private, parameter:: psb_int8_type = psb_char_type + 1 + + + type psb_buffer_node + integer :: request + integer :: icontxt + integer :: buffer_type + integer(psb_int_k_), allocatable :: intbuf(:) + integer(psb_long_int_k_), allocatable :: int8buf(:) + real(psb_spk_), allocatable :: realbuf(:) + real(psb_dpk_), allocatable :: doublebuf(:) + complex(psb_spk_), allocatable :: complexbuf(:) + complex(psb_dpk_), allocatable :: dcomplbuf(:) + logical, allocatable :: logbuf(:) + character(len=1), allocatable :: charbuf(:) + type(psb_buffer_node), pointer :: prev=>null(), next=>null() + end type psb_buffer_node + + type psb_buffer_queue + type(psb_buffer_node), pointer :: head=>null(), tail=>null() + end type psb_buffer_queue + + + interface psi_snd + module procedure psi_isnd,& + & psi_ssnd, psi_dsnd,& + & psi_csnd, psi_zsnd,& + & psi_lsnd, psi_hsnd + end interface +#if !defined(LONG_INTEGERS) + interface psi_snd + module procedure psi_i8snd + end interface +#endif + +contains + + subroutine psb_init_queue(mesg_queue,info) + type(psb_buffer_queue), intent(inout) :: mesg_queue + type(psb_buffer_node), pointer :: item + + info = 0 + if ((.not.associated(mesg_queue%head)).and.& + & (.not.associated(mesg_queue%tail))) then + ! Nothing to do + return + end if + + if ((.not.associated(mesg_queue%head)).or.& + & (.not.associated(mesg_queue%tail))) then + ! If we are here one is associated, the other is not. + ! This is impossible. + info = -1 + write(0,*) 'Wrong status on init ' + return + end if + + end subroutine psb_init_queue + + subroutine psb_wait_buffer(node, info) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_buffer_node), intent(inout) :: node + integer, intent(out) :: info + integer :: status(mpi_status_size) + + call mpi_wait(node%request,status,info) + end subroutine psb_wait_buffer + + subroutine psb_test_buffer(node, flag, info) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_buffer_node), intent(inout) :: node + logical, intent(out) :: flag + integer, intent(out) :: info + integer :: status(mpi_status_size) + + call mpi_test(node%request,flag,status,info) + end subroutine psb_test_buffer + + + subroutine psb_close_context(mesg_queue,icontxt) + type(psb_buffer_queue), intent(inout) :: mesg_queue + integer, intent(in) :: icontxt + integer :: info + type(psb_buffer_node), pointer :: node, nextnode + + node => mesg_queue%head + do + if (.not.associated(node)) exit + nextnode => node%next + if (node%icontxt == icontxt) then + call psb_wait_buffer(node,info) + call psb_delete_node(mesg_queue,node) + end if + node => nextnode + end do + end subroutine psb_close_context + + subroutine psb_close_all_context(mesg_queue) + type(psb_buffer_queue), intent(inout) :: mesg_queue + type(psb_buffer_node), pointer :: node, nextnode + integer :: info + + node => mesg_queue%head + do + if (.not.associated(node)) exit + nextnode => node%next + call psb_wait_buffer(node,info) + call psb_delete_node(mesg_queue,node) + node => nextnode + end do + end subroutine psb_close_all_context + + + subroutine psb_delete_node(mesg_queue,node) + type(psb_buffer_queue), intent(inout) :: mesg_queue + type(psb_buffer_node), pointer :: node + type(psb_buffer_node), pointer :: prevnode + + if (.not.associated(node)) then + return + end if + prevnode => node%prev + if (associated(mesg_queue%head,node)) mesg_queue%head => node%next + if (associated(mesg_queue%tail,node)) mesg_queue%tail => prevnode + if (associated(prevnode)) prevnode%next => node%next + if (associated(node%next)) node%next%prev => prevnode + deallocate(node) + + end subroutine psb_delete_node + + subroutine psb_insert_node(mesg_queue,node) + type(psb_buffer_queue), intent(inout) :: mesg_queue + type(psb_buffer_node), pointer :: node + + node%next => null() + node%prev => null() + if ((.not.associated(mesg_queue%head)).and.& + & (.not.associated(mesg_queue%tail))) then + mesg_Queue%head => node + mesg_queue%tail => node + return + end if + mesg_queue%tail%next => node + node%prev => mesg_queue%tail + mesg_queue%tail => node + + end subroutine psb_insert_node + + subroutine psb_test_nodes(mesg_queue) + type(psb_buffer_queue) :: mesg_queue + type(psb_buffer_node), pointer :: node, nextnode + integer :: info + logical :: flag + + node => mesg_queue%head + do + if (.not.associated(node)) exit + nextnode => node%next + call psb_test_buffer(node,flag,info) + if (flag) then + call psb_delete_node(mesg_queue,node) + end if + node => nextnode + end do + end subroutine psb_test_nodes + + ! !!!!!!!!!!!!!!!!! + ! + ! Inner send. Basic idea: + ! the input buffer is MOVE_ALLOCed + ! to a node in the mesg queue, then it is sent. + ! Thus the calling process should guarantee that + ! the buffer is dispensable, i.e. the user data + ! has already been copied. + ! + ! !!!!!!!!!!!!!!!!! + subroutine psi_isnd(icontxt,tag,dest,buffer,mesg_queue) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer :: icontxt, tag, dest + integer(psb_int_k_), allocatable, intent(inout) :: buffer(:) + type(psb_buffer_queue) :: mesg_queue + type(psb_buffer_node), pointer :: node + integer :: info + + allocate(node, stat=info) + if (info /= 0) then + write(0,*) 'Fatal memory error inside communication subsystem' + return + end if + node%icontxt = icontxt + node%buffer_type = psb_int_type + call move_alloc(buffer,node%intbuf) + if (info /= 0) then + write(0,*) 'Fatal memory error inside communication subsystem' + return + end if + call mpi_isend(node%intbuf,size(node%intbuf),psb_mpi_integer,& + & dest,tag,icontxt,node%request,info) + call psb_insert_node(mesg_queue,node) + + call psb_test_nodes(mesg_queue) + + end subroutine psi_isnd + +#if !defined(LONG_INTEGERS) + subroutine psi_i8snd(icontxt,tag,dest,buffer,mesg_queue) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer :: icontxt, tag, dest + integer(psb_long_int_k_), allocatable, intent(inout) :: buffer(:) + type(psb_buffer_queue) :: mesg_queue + type(psb_buffer_node), pointer :: node + integer :: info + + allocate(node, stat=info) + if (info /= 0) then + write(0,*) 'Fatal memory error inside communication subsystem' + return + end if + node%icontxt = icontxt + node%buffer_type = psb_int8_type + call move_alloc(buffer,node%int8buf) + if (info /= 0) then + write(0,*) 'Fatal memory error inside communication subsystem' + return + end if + call mpi_isend(node%int8buf,size(node%int8buf),mpi_integer8,& + & dest,tag,icontxt,node%request,info) + call psb_insert_node(mesg_queue,node) + + call psb_test_nodes(mesg_queue) + + end subroutine psi_i8snd +#endif + + + subroutine psi_ssnd(icontxt,tag,dest,buffer,mesg_queue) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer :: icontxt, tag, dest + real(psb_spk_), allocatable, intent(inout) :: buffer(:) + type(psb_buffer_queue) :: mesg_queue + type(psb_buffer_node), pointer :: node + integer :: info + + allocate(node, stat=info) + if (info /= 0) then + write(0,*) 'Fatal memory error inside communication subsystem' + return + end if + node%icontxt = icontxt + node%buffer_type = psb_real_type + call move_alloc(buffer,node%realbuf) + if (info /= 0) then + write(0,*) 'Fatal memory error inside communication subsystem' + return + end if + call mpi_isend(node%realbuf,size(node%realbuf),mpi_real,& + & dest,tag,icontxt,node%request,info) + call psb_insert_node(mesg_queue,node) + + call psb_test_nodes(mesg_queue) + + end subroutine psi_ssnd + + subroutine psi_dsnd(icontxt,tag,dest,buffer,mesg_queue) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer :: icontxt, tag, dest + real(psb_dpk_), allocatable, intent(inout) :: buffer(:) + type(psb_buffer_queue) :: mesg_queue + type(psb_buffer_node), pointer :: node + integer :: info + + allocate(node, stat=info) + if (info /= 0) then + write(0,*) 'Fatal memory error inside communication subsystem' + return + end if + node%icontxt = icontxt + node%buffer_type = psb_double_type + call move_alloc(buffer,node%doublebuf) + if (info /= 0) then + write(0,*) 'Fatal memory error inside communication subsystem' + return + end if + call mpi_isend(node%doublebuf,size(node%doublebuf),mpi_double_precision,& + & dest,tag,icontxt,node%request,info) + call psb_insert_node(mesg_queue,node) + + call psb_test_nodes(mesg_queue) + + end subroutine psi_dsnd + + subroutine psi_csnd(icontxt,tag,dest,buffer,mesg_queue) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer :: icontxt, tag, dest + complex(psb_spk_), allocatable, intent(inout) :: buffer(:) + type(psb_buffer_queue) :: mesg_queue + type(psb_buffer_node), pointer :: node + integer :: info + + allocate(node, stat=info) + if (info /= 0) then + write(0,*) 'Fatal memory error inside communication subsystem' + return + end if + node%icontxt = icontxt + node%buffer_type = psb_complex_type + call move_alloc(buffer,node%complexbuf) + if (info /= 0) then + write(0,*) 'Fatal memory error inside communication subsystem' + return + end if + call mpi_isend(node%complexbuf,size(node%complexbuf),mpi_complex,& + & dest,tag,icontxt,node%request,info) + call psb_insert_node(mesg_queue,node) + + call psb_test_nodes(mesg_queue) + + end subroutine psi_csnd + + subroutine psi_zsnd(icontxt,tag,dest,buffer,mesg_queue) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer :: icontxt, tag, dest + complex(psb_dpk_), allocatable, intent(inout) :: buffer(:) + type(psb_buffer_queue) :: mesg_queue + type(psb_buffer_node), pointer :: node + integer :: info + + allocate(node, stat=info) + if (info /= 0) then + write(0,*) 'Fatal memory error inside communication subsystem' + return + end if + node%icontxt = icontxt + node%buffer_type = psb_dcomplex_type + call move_alloc(buffer,node%dcomplbuf) + if (info /= 0) then + write(0,*) 'Fatal memory error inside communication subsystem' + return + end if + call mpi_isend(node%dcomplbuf,size(node%dcomplbuf),mpi_double_complex,& + & dest,tag,icontxt,node%request,info) + call psb_insert_node(mesg_queue,node) + + call psb_test_nodes(mesg_queue) + + end subroutine psi_zsnd + + + subroutine psi_lsnd(icontxt,tag,dest,buffer,mesg_queue) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer :: icontxt, tag, dest + logical, allocatable, intent(inout) :: buffer(:) + type(psb_buffer_queue) :: mesg_queue + type(psb_buffer_node), pointer :: node + integer :: info + + allocate(node, stat=info) + if (info /= 0) then + write(0,*) 'Fatal memory error inside communication subsystem' + return + end if + node%icontxt = icontxt + node%buffer_type = psb_logical_type + call move_alloc(buffer,node%logbuf) + if (info /= 0) then + write(0,*) 'Fatal memory error inside communication subsystem' + return + end if + call mpi_isend(node%logbuf,size(node%logbuf),mpi_logical,& + & dest,tag,icontxt,node%request,info) + call psb_insert_node(mesg_queue,node) + + call psb_test_nodes(mesg_queue) + + end subroutine psi_lsnd + + + subroutine psi_hsnd(icontxt,tag,dest,buffer,mesg_queue) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer :: icontxt, tag, dest + character(len=1), allocatable, intent(inout) :: buffer(:) + type(psb_buffer_queue) :: mesg_queue + type(psb_buffer_node), pointer :: node + integer :: info + + allocate(node, stat=info) + if (info /= 0) then + write(0,*) 'Fatal memory error inside communication subsystem' + return + end if + node%icontxt = icontxt + node%buffer_type = psb_char_type + call move_alloc(buffer,node%charbuf) + if (info /= 0) then + write(0,*) 'Fatal memory error inside communication subsystem' + return + end if + call mpi_isend(node%charbuf,size(node%charbuf),mpi_character,& + & dest,tag,icontxt,node%request,info) + call psb_insert_node(mesg_queue,node) + + call psb_test_nodes(mesg_queue) + + end subroutine psi_hsnd + + +end module psi_comm_buffers_mod + diff --git a/base/modules/psi_p2p_mod.F90 b/base/modules/psi_p2p_mod.F90 new file mode 100644 index 00000000..177e09cc --- /dev/null +++ b/base/modules/psi_p2p_mod.F90 @@ -0,0 +1,1339 @@ + +module psi_p2p_mod + use psi_penv_mod + use psi_comm_buffers_mod + + interface psb_snd + module procedure psb_isnds, psb_isndv, psb_isndm, & + & psb_ssnds, psb_ssndv, psb_ssndm,& + & psb_dsnds, psb_dsndv, psb_dsndm,& + & psb_csnds, psb_csndv, psb_csndm,& + & psb_zsnds, psb_zsndv, psb_zsndm,& + & psb_lsnds, psb_lsndv, psb_lsndm,& + & psb_hsnds + end interface + + interface psb_rcv + module procedure psb_ircvs, psb_ircvv, psb_ircvm, & + & psb_srcvs, psb_srcvv, psb_srcvm,& + & psb_drcvs, psb_drcvv, psb_drcvm,& + & psb_crcvs, psb_crcvv, psb_crcvm,& + & psb_zrcvs, psb_zrcvv, psb_zrcvm,& + & psb_lrcvs, psb_lrcvv, psb_lrcvm,& + & psb_hrcvs + end interface + + +#if !defined(LONG_INTEGERS) + interface psb_snd + module procedure psb_i8snds, psb_i8sndv, psb_i8sndm + end interface + + interface psb_rcv + module procedure psb_i8rcvs, psb_i8rcvv, psb_i8rcvm + end interface +#endif + + + + + integer, private, parameter:: psb_int_tag = 543987 + integer, private, parameter:: psb_real_tag = psb_int_tag + 1 + integer, private, parameter:: psb_double_tag = psb_real_tag + 1 + integer, private, parameter:: psb_complex_tag = psb_double_tag + 1 + integer, private, parameter:: psb_dcomplex_tag = psb_complex_tag + 1 + integer, private, parameter:: psb_logical_tag = psb_dcomplex_tag + 1 + integer, private, parameter:: psb_char_tag = psb_logical_tag + 1 + integer, private, parameter:: psb_int8_tag = psb_char_tag + 1 + + integer, parameter:: psb_int_swap_tag = psb_int_tag + psb_int_tag + integer, parameter:: psb_real_swap_tag = psb_real_tag + psb_int_tag + integer, parameter:: psb_double_swap_tag = psb_double_tag + psb_int_tag + integer, parameter:: psb_complex_swap_tag = psb_complex_tag + psb_int_tag + integer, parameter:: psb_dcomplex_swap_tag = psb_dcomplex_tag + psb_int_tag + integer, parameter:: psb_logical_swap_tag = psb_logical_tag + psb_int_tag + integer, parameter:: psb_char_swap_tag = psb_char_tag + psb_int_tag + integer, parameter:: psb_int8_swap_tag = psb_int8_tag + psb_int_tag + + +contains + + + ! !!!!!!!!!!!!!!!!!!!!!!!! + ! + ! Point-to-point SND + ! + ! !!!!!!!!!!!!!!!!!!!!!!!! + + subroutine psb_isnds(ictxt,dat,dst) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_int_k_), intent(in) :: dat + integer, intent(in) :: dst + integer(psb_int_k_), allocatable :: dat_(:) + integer :: info +#if defined(SERIAL_MPI) + ! do nothing +#else + allocate(dat_(1), stat=info) + dat_(1) = dat + call psi_snd(ictxt,psb_int_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_isnds + + subroutine psb_isndv(ictxt,dat,dst) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_int_k_), intent(in) :: dat(:) + integer, intent(in) :: dst + integer(psb_int_k_), allocatable :: dat_(:) + integer :: info + +#if defined(SERIAL_MPI) +#else + allocate(dat_(size(dat)), stat=info) + dat_(:) = dat(:) + call psi_snd(ictxt,psb_int_tag,dst,dat_,psb_mesg_queue) +#endif + + end subroutine psb_isndv + + subroutine psb_isndm(ictxt,dat,dst,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_int_k_), intent(in) :: dat(:,:) + integer, intent(in) :: dst + integer, intent(in), optional :: m + integer(psb_int_k_), allocatable :: dat_(:) + integer :: info ,i,j,k,m_,n_ + +#if defined(SERIAL_MPI) +#else + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + end if + n_ = size(dat,2) + allocate(dat_(m_*n_), stat=info) + k=1 + do j=1,n_ + do i=1, m_ + dat_(k) = dat(i,j) + k = k + 1 + end do + end do + call psi_snd(ictxt,psb_int_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_isndm + + subroutine psb_ssnds(ictxt,dat,dst) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(in) :: dat + integer, intent(in) :: dst + real(psb_spk_), allocatable :: dat_(:) + integer :: info +#if defined(SERIAL_MPI) + ! do nothing +#else + allocate(dat_(1), stat=info) + dat_(1) = dat + call psi_snd(ictxt,psb_real_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_ssnds + + subroutine psb_ssndv(ictxt,dat,dst) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(in) :: dat(:) + integer, intent(in) :: dst + real(psb_spk_), allocatable :: dat_(:) + integer :: info + +#if defined(SERIAL_MPI) +#else + allocate(dat_(size(dat)), stat=info) + dat_(:) = dat(:) + call psi_snd(ictxt,psb_real_tag,dst,dat_,psb_mesg_queue) +#endif + + end subroutine psb_ssndv + + subroutine psb_ssndm(ictxt,dat,dst,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(in) :: dat(:,:) + integer, intent(in) :: dst + integer, intent(in), optional :: m + real(psb_spk_), allocatable :: dat_(:) + integer :: info ,i,j,k,m_,n_ + +#if defined(SERIAL_MPI) +#else + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + end if + n_ = size(dat,2) + allocate(dat_(m_*n_), stat=info) + k=1 + do j=1,n_ + do i=1, m_ + dat_(k) = dat(i,j) + k = k + 1 + end do + end do + call psi_snd(ictxt,psb_real_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_ssndm + + + subroutine psb_dsnds(ictxt,dat,dst) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(in) :: dat + integer, intent(in) :: dst + real(psb_dpk_), allocatable :: dat_(:) + integer :: info +#if defined(SERIAL_MPI) + ! do nothing +#else + allocate(dat_(1), stat=info) + dat_(1) = dat + call psi_snd(ictxt,psb_double_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_dsnds + + subroutine psb_dsndv(ictxt,dat,dst) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(in) :: dat(:) + integer, intent(in) :: dst + real(psb_dpk_), allocatable :: dat_(:) + integer :: info + +#if defined(SERIAL_MPI) +#else + allocate(dat_(size(dat)), stat=info) + dat_(:) = dat(:) + call psi_snd(ictxt,psb_double_tag,dst,dat_,psb_mesg_queue) +#endif + + end subroutine psb_dsndv + + subroutine psb_dsndm(ictxt,dat,dst,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(in) :: dat(:,:) + integer, intent(in) :: dst + integer, intent(in), optional :: m + real(psb_dpk_), allocatable :: dat_(:) + integer :: info ,i,j,k,m_,n_ + +#if defined(SERIAL_MPI) +#else + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + end if + n_ = size(dat,2) + allocate(dat_(m_*n_), stat=info) + k=1 + do j=1,n_ + do i=1, m_ + dat_(k) = dat(i,j) + k = k + 1 + end do + end do + call psi_snd(ictxt,psb_double_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_dsndm + + + subroutine psb_csnds(ictxt,dat,dst) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_spk_), intent(in) :: dat + integer, intent(in) :: dst + complex(psb_spk_), allocatable :: dat_(:) + integer :: info +#if defined(SERIAL_MPI) + ! do nothing +#else + allocate(dat_(1), stat=info) + dat_(1) = dat + call psi_snd(ictxt,psb_complex_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_csnds + + subroutine psb_csndv(ictxt,dat,dst) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_spk_), intent(in) :: dat(:) + integer, intent(in) :: dst + complex(psb_spk_), allocatable :: dat_(:) + integer :: info + +#if defined(SERIAL_MPI) +#else + allocate(dat_(size(dat)), stat=info) + dat_(:) = dat(:) + call psi_snd(ictxt,psb_complex_tag,dst,dat_,psb_mesg_queue) +#endif + + end subroutine psb_csndv + + subroutine psb_csndm(ictxt,dat,dst,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_spk_), intent(in) :: dat(:,:) + integer, intent(in) :: dst + integer, intent(in), optional :: m + complex(psb_spk_), allocatable :: dat_(:) + integer :: info ,i,j,k,m_,n_ + +#if defined(SERIAL_MPI) +#else + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + end if + n_ = size(dat,2) + allocate(dat_(m_*n_), stat=info) + k=1 + do j=1,n_ + do i=1, m_ + dat_(k) = dat(i,j) + k = k + 1 + end do + end do + call psi_snd(ictxt,psb_complex_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_csndm + + + subroutine psb_zsnds(ictxt,dat,dst) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(in) :: dat + integer, intent(in) :: dst + complex(psb_dpk_), allocatable :: dat_(:) + integer :: info +#if defined(SERIAL_MPI) + ! do nothing +#else + allocate(dat_(1), stat=info) + dat_(1) = dat + call psi_snd(ictxt,psb_dcomplex_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_zsnds + + subroutine psb_zsndv(ictxt,dat,dst) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(in) :: dat(:) + integer, intent(in) :: dst + complex(psb_dpk_), allocatable :: dat_(:) + integer :: info + +#if defined(SERIAL_MPI) +#else + allocate(dat_(size(dat)), stat=info) + dat_(:) = dat(:) + call psi_snd(ictxt,psb_dcomplex_tag,dst,dat_,psb_mesg_queue) +#endif + + end subroutine psb_zsndv + + subroutine psb_zsndm(ictxt,dat,dst,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(in) :: dat(:,:) + integer, intent(in) :: dst + integer, intent(in), optional :: m + complex(psb_dpk_), allocatable :: dat_(:) + integer :: info ,i,j,k,m_,n_ + +#if defined(SERIAL_MPI) +#else + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + end if + n_ = size(dat,2) + allocate(dat_(m_*n_), stat=info) + k=1 + do j=1,n_ + do i=1, m_ + dat_(k) = dat(i,j) + k = k + 1 + end do + end do + call psi_snd(ictxt,psb_dcomplex_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_zsndm + + + subroutine psb_lsnds(ictxt,dat,dst) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + logical, intent(in) :: dat + integer, intent(in) :: dst + logical, allocatable :: dat_(:) + integer :: info +#if defined(SERIAL_MPI) + ! do nothing +#else + allocate(dat_(1), stat=info) + dat_(1) = dat + call psi_snd(ictxt,psb_logical_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_lsnds + + subroutine psb_lsndv(ictxt,dat,dst) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + logical, intent(in) :: dat(:) + integer, intent(in) :: dst + logical, allocatable :: dat_(:) + integer :: info + +#if defined(SERIAL_MPI) +#else + allocate(dat_(size(dat)), stat=info) + dat_(:) = dat(:) + call psi_snd(ictxt,psb_logical_tag,dst,dat_,psb_mesg_queue) +#endif + + end subroutine psb_lsndv + + subroutine psb_lsndm(ictxt,dat,dst,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + logical, intent(in) :: dat(:,:) + integer, intent(in) :: dst + integer, intent(in), optional :: m + logical, allocatable :: dat_(:) + integer :: info ,i,j,k,m_,n_ + +#if defined(SERIAL_MPI) +#else + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + end if + n_ = size(dat,2) + allocate(dat_(m_*n_), stat=info) + k=1 + do j=1,n_ + do i=1, m_ + dat_(k) = dat(i,j) + k = k + 1 + end do + end do + call psi_snd(ictxt,psb_logical_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_lsndm + + + subroutine psb_hsnds(ictxt,dat,dst) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + character(len=*), intent(in) :: dat + integer, intent(in) :: dst + character(len=1), allocatable :: dat_(:) + integer :: info, l, i +#if defined(SERIAL_MPI) + ! do nothing +#else + l = len(dat) + allocate(dat_(l), stat=info) + do i=1, l + dat_(i) = dat(i:i) + end do + call psi_snd(ictxt,psb_char_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_hsnds + +#if !defined(LONG_INTEGERS) + subroutine psb_i8snds(ictxt,dat,dst) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_long_int_k_), intent(in) :: dat + integer, intent(in) :: dst + integer(psb_long_int_k_), allocatable :: dat_(:) + integer :: info +#if defined(SERIAL_MPI) + ! do nothing +#else + allocate(dat_(1), stat=info) + dat_(1) = dat + call psi_snd(ictxt,psb_int8_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_i8snds + + subroutine psb_i8sndv(ictxt,dat,dst) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_long_int_k_), intent(in) :: dat(:) + integer, intent(in) :: dst + integer(psb_long_int_k_), allocatable :: dat_(:) + integer :: info + +#if defined(SERIAL_MPI) +#else + allocate(dat_(size(dat)), stat=info) + dat_(:) = dat(:) + call psi_snd(ictxt,psb_int8_tag,dst,dat_,psb_mesg_queue) +#endif + + end subroutine psb_i8sndv + + subroutine psb_i8sndm(ictxt,dat,dst,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_long_int_k_), intent(in) :: dat(:,:) + integer, intent(in) :: dst + integer, intent(in), optional :: m + integer(psb_long_int_k_), allocatable :: dat_(:) + integer :: info ,i,j,k,m_,n_ + +#if defined(SERIAL_MPI) +#else + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + end if + n_ = size(dat,2) + allocate(dat_(m_*n_), stat=info) + k=1 + do j=1,n_ + do i=1, m_ + dat_(k) = dat(i,j) + k = k + 1 + end do + end do + call psi_snd(ictxt,psb_int8_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_i8sndm + +#endif + + ! !!!!!!!!!!!!!!!!!!!!!!!! + ! + ! Point-to-point RCV + ! + ! !!!!!!!!!!!!!!!!!!!!!!!! + + subroutine psb_ircvs(ictxt,dat,src) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_int_k_), intent(out) :: dat + integer, intent(in) :: src + integer :: info + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! do nothing +#else + call mpi_recv(dat,1,psb_mpi_integer,src,psb_int_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_ircvs + + subroutine psb_ircvv(ictxt,dat,src) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_int_k_), intent(out) :: dat(:) + integer, intent(in) :: src + integer(psb_int_k_), allocatable :: dat_(:) + integer :: info + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) +#else + call mpi_recv(dat,size(dat),psb_mpi_integer,src,psb_int_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + + end subroutine psb_ircvv + + subroutine psb_ircvm(ictxt,dat,src,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_int_k_), intent(out) :: dat(:,:) + integer, intent(in) :: src + integer, intent(in), optional :: m + integer(psb_int_k_), allocatable :: dat_(:) + integer :: info ,i,j,k,m_,n_, ld, mp_rcv_type + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! What should we do here?? +#else + if (present(m)) then + m_ = m + ld = size(dat,1) + n_ = size(dat,2) + call mpi_type_vector(n_,m_,ld,psb_mpi_integer,mp_rcv_type,info) + if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) + if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& + & psb_int_tag,ictxt,status,info) + if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) + else + call mpi_recv(dat,size(dat),psb_mpi_integer,src,psb_int_tag,ictxt,status,info) + end if + if (info /= mpi_success) then + write(0,*) 'Error in psb_recv', info + end if + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_ircvm + + + subroutine psb_srcvs(ictxt,dat,src) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(out) :: dat + integer, intent(in) :: src + integer :: info + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! do nothing +#else + call mpi_recv(dat,1,mpi_real,src,psb_real_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_srcvs + + subroutine psb_srcvv(ictxt,dat,src) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(out) :: dat(:) + integer, intent(in) :: src + real(psb_spk_), allocatable :: dat_(:) + integer :: info + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) +#else + call mpi_recv(dat,size(dat),mpi_real,src,psb_real_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + + end subroutine psb_srcvv + + subroutine psb_srcvm(ictxt,dat,src,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(out) :: dat(:,:) + integer, intent(in) :: src + integer, intent(in), optional :: m + real(psb_spk_), allocatable :: dat_(:) + integer :: info ,i,j,k,m_,n_, ld, mp_rcv_type + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! What should we do here?? +#else + if (present(m)) then + m_ = m + ld = size(dat,1) + n_ = size(dat,2) + call mpi_type_vector(n_,m_,ld,mpi_real,mp_rcv_type,info) + if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) + if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& + & psb_real_tag,ictxt,status,info) + if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) + else + call mpi_recv(dat,size(dat),mpi_real,src,psb_real_tag,ictxt,status,info) + end if + if (info /= mpi_success) then + write(0,*) 'Error in psb_recv', info + end if + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_srcvm + + + subroutine psb_drcvs(ictxt,dat,src) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(out) :: dat + integer, intent(in) :: src + integer :: info + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! do nothing +#else + call mpi_recv(dat,1,mpi_double_precision,src,psb_double_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_drcvs + + subroutine psb_drcvv(ictxt,dat,src) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(out) :: dat(:) + integer, intent(in) :: src + real(psb_dpk_), allocatable :: dat_(:) + integer :: info + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) +#else + call mpi_recv(dat,size(dat),mpi_double_precision,src,psb_double_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + + end subroutine psb_drcvv + + subroutine psb_drcvm(ictxt,dat,src,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(out) :: dat(:,:) + integer, intent(in) :: src + integer, intent(in), optional :: m + real(psb_dpk_), allocatable :: dat_(:) + integer :: info ,i,j,k,m_,n_, ld, mp_rcv_type + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! What should we do here?? +#else + if (present(m)) then + m_ = m + ld = size(dat,1) + n_ = size(dat,2) + call mpi_type_vector(n_,m_,ld,mpi_double_precision,mp_rcv_type,info) + if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) + if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& + & psb_double_tag,ictxt,status,info) + if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) + else + call mpi_recv(dat,size(dat),mpi_double_precision,src,& + & psb_double_tag,ictxt,status,info) + end if + if (info /= mpi_success) then + write(0,*) 'Error in psb_recv', info + end if + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_drcvm + + + subroutine psb_crcvs(ictxt,dat,src) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_spk_), intent(out) :: dat + integer, intent(in) :: src + integer :: info + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! do nothing +#else + call mpi_recv(dat,1,mpi_complex,src,psb_complex_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_crcvs + + subroutine psb_crcvv(ictxt,dat,src) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_spk_), intent(out) :: dat(:) + integer, intent(in) :: src + complex(psb_spk_), allocatable :: dat_(:) + integer :: info + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) +#else + call mpi_recv(dat,size(dat),mpi_complex,src,psb_complex_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + + end subroutine psb_crcvv + + subroutine psb_crcvm(ictxt,dat,src,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_spk_), intent(out) :: dat(:,:) + integer, intent(in) :: src + integer, intent(in), optional :: m + complex(psb_spk_), allocatable :: dat_(:) + integer :: info ,i,j,k,m_,n_, ld, mp_rcv_type + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! What should we do here?? +#else + if (present(m)) then + m_ = m + ld = size(dat,1) + n_ = size(dat,2) + call mpi_type_vector(n_,m_,ld,mpi_complex,mp_rcv_type,info) + if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) + if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& + & psb_complex_tag,ictxt,status,info) + if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) + else + call mpi_recv(dat,size(dat),mpi_complex,src,& + & psb_complex_tag,ictxt,status,info) + end if + if (info /= mpi_success) then + write(0,*) 'Error in psb_recv', info + end if + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_crcvm + + + subroutine psb_zrcvs(ictxt,dat,src) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(out) :: dat + integer, intent(in) :: src + integer :: info + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! do nothing +#else + call mpi_recv(dat,1,mpi_double_complex,src,psb_dcomplex_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_zrcvs + + subroutine psb_zrcvv(ictxt,dat,src) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(out) :: dat(:) + integer, intent(in) :: src + complex(psb_dpk_), allocatable :: dat_(:) + integer :: info + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) +#else + call mpi_recv(dat,size(dat),mpi_double_complex,src,psb_dcomplex_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + + end subroutine psb_zrcvv + + subroutine psb_zrcvm(ictxt,dat,src,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(out) :: dat(:,:) + integer, intent(in) :: src + integer, intent(in), optional :: m + complex(psb_dpk_), allocatable :: dat_(:) + integer :: info ,i,j,k,m_,n_, ld, mp_rcv_type + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! What should we do here?? +#else + if (present(m)) then + m_ = m + ld = size(dat,1) + n_ = size(dat,2) + call mpi_type_vector(n_,m_,ld,mpi_double_complex,mp_rcv_type,info) + if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) + if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& + & psb_dcomplex_tag,ictxt,status,info) + if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) + else + call mpi_recv(dat,size(dat),mpi_double_complex,src,& + & psb_dcomplex_tag,ictxt,status,info) + end if + if (info /= mpi_success) then + write(0,*) 'Error in psb_recv', info + end if + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_zrcvm + + + subroutine psb_lrcvs(ictxt,dat,src) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + logical, intent(out) :: dat + integer, intent(in) :: src + integer :: info + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! do nothing +#else + call mpi_recv(dat,1,mpi_logical,src,psb_logical_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_lrcvs + + subroutine psb_lrcvv(ictxt,dat,src) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + logical, intent(out) :: dat(:) + integer, intent(in) :: src + integer :: info + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) +#else + call mpi_recv(dat,size(dat),mpi_logical,src,psb_logical_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + + end subroutine psb_lrcvv + + subroutine psb_lrcvm(ictxt,dat,src,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + logical, intent(out) :: dat(:,:) + integer, intent(in) :: src + integer, intent(in), optional :: m + integer :: info ,i,j,k,m_,n_, ld, mp_rcv_type + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! What should we do here?? +#else + if (present(m)) then + m_ = m + ld = size(dat,1) + n_ = size(dat,2) + call mpi_type_vector(n_,m_,ld,mpi_logical,mp_rcv_type,info) + if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) + if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& + & psb_logical_tag,ictxt,status,info) + if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) + else + call mpi_recv(dat,size(dat),mpi_logical,src,& + & psb_logical_tag,ictxt,status,info) + end if + if (info /= mpi_success) then + write(0,*) 'Error in psb_recv', info + end if + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_lrcvm + + + subroutine psb_hrcvs(ictxt,dat,src) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + character(len=*), intent(out) :: dat + integer, intent(in) :: src + character(len=1), allocatable :: dat_(:) + integer :: info, l, i + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! do nothing +#else + l = len(dat) + allocate(dat_(l), stat=info) + call mpi_recv(dat_,l,mpi_character,src,psb_char_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) + do i=1, l + dat(i:i) = dat_(i) + end do + deallocate(dat_) +#endif + end subroutine psb_hrcvs + + +#if !defined(LONG_INTEGERS) + + subroutine psb_i8rcvs(ictxt,dat,src) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_long_int_k_), intent(out) :: dat + integer, intent(in) :: src + integer :: info + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! do nothing +#else + call mpi_recv(dat,1,mpi_integer8,src,psb_int8_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_i8rcvs + + subroutine psb_i8rcvv(ictxt,dat,src) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_long_int_k_), intent(out) :: dat(:) + integer, intent(in) :: src + integer :: info + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) +#else + call mpi_recv(dat,size(dat),mpi_integer8,src,psb_int8_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + + end subroutine psb_i8rcvv + + subroutine psb_i8rcvm(ictxt,dat,src,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_long_int_k_), intent(out) :: dat(:,:) + integer, intent(in) :: src + integer, intent(in), optional :: m + integer :: info ,i,j,k,m_,n_, ld, mp_rcv_type + integer :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! What should we do here?? +#else + if (present(m)) then + m_ = m + ld = size(dat,1) + n_ = size(dat,2) + call mpi_type_vector(n_,m_,ld,mpi_integer8,mp_rcv_type,info) + if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) + if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& + & psb_int8_tag,ictxt,status,info) + if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) + else + call mpi_recv(dat,size(dat),mpi_integer8,src,& + & psb_int8_tag,ictxt,status,info) + end if + if (info /= mpi_success) then + write(0,*) 'Error in psb_recv', info + end if + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_i8rcvm + +#endif + +end module psi_p2p_mod diff --git a/base/modules/psi_penv_mod.F90 b/base/modules/psi_penv_mod.F90 new file mode 100644 index 00000000..c8810017 --- /dev/null +++ b/base/modules/psi_penv_mod.F90 @@ -0,0 +1,572 @@ +module psi_penv_mod + use psb_const_mod + use psi_comm_buffers_mod, only : psb_buffer_queue + + interface psb_init + module procedure psb_init + end interface + + interface psb_exit + module procedure psb_exit + end interface + + interface psb_abort + module procedure psb_abort + end interface + + interface psb_info + module procedure psb_info + end interface + + interface psb_barrier + module procedure psb_barrier + end interface + + interface psb_wtime + module procedure psb_wtime + end interface + + +#if defined(SERIAL_MPI) + integer, private, save :: nctxt=0 + +#else + + integer, save :: mpi_iamx_op, mpi_iamn_op + integer, save :: mpi_i8amx_op, mpi_i8amn_op + integer, save :: mpi_samx_op, mpi_samn_op + integer, save :: mpi_damx_op, mpi_damn_op + integer, save :: mpi_camx_op, mpi_camn_op + integer, save :: mpi_zamx_op, mpi_zamn_op + integer, save :: mpi_snrm2_op, mpi_dnrm2_op + + type(psb_buffer_queue), save :: psb_mesg_queue + +#endif + + private :: psi_get_sizes, psi_register_mpi_extras + private :: psi_iamx_op, psi_iamn_op + private :: psi_i8amx_op, psi_i8amn_op + private :: psi_samx_op, psi_samn_op + private :: psi_damx_op, psi_damn_op + private :: psi_camx_op, psi_camn_op + private :: psi_zamx_op, psi_zamn_op + private :: psi_snrm2_op, psi_dnrm2_op + + +contains + ! !!!!!!!!!!!!!!!!!!!!!! + ! + ! Environment handling + ! + ! !!!!!!!!!!!!!!!!!!!!!! + + subroutine psi_get_sizes() + use psb_const_mod + real(psb_dpk_) :: dv(2) + real(psb_spk_) :: sv(2) + integer :: iv(2) + integer(psb_long_int_k_) :: ilv(2) + + call psi_c_diffadd(sv(1),sv(2),psb_sizeof_sp) + call psi_c_diffadd(dv(1),dv(2),psb_sizeof_dp) + call psi_c_diffadd(iv(1),iv(2),psb_sizeof_int) + call psi_c_diffadd(ilv(1),ilv(2),psb_sizeof_long_int) + + end subroutine psi_get_sizes + + subroutine psi_register_mpi_extras(info) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer info + info = 0 + +#if defined(LONG_INTEGERS) + psb_mpi_integer = mpi_integer8 +#else + psb_mpi_integer = mpi_integer +#endif + + if (info == 0) call mpi_op_create(psi_iamx_op,.true.,mpi_iamx_op,info) + if (info == 0) call mpi_op_create(psi_iamn_op,.true.,mpi_iamn_op,info) + if (info == 0) call mpi_op_create(psi_i8amx_op,.true.,mpi_i8amx_op,info) + if (info == 0) call mpi_op_create(psi_i8amn_op,.true.,mpi_i8amn_op,info) + if (info == 0) call mpi_op_create(psi_samx_op,.true.,mpi_samx_op,info) + if (info == 0) call mpi_op_create(psi_samn_op,.true.,mpi_samn_op,info) + if (info == 0) call mpi_op_create(psi_damx_op,.true.,mpi_damx_op,info) + if (info == 0) call mpi_op_create(psi_damn_op,.true.,mpi_damn_op,info) + if (info == 0) call mpi_op_create(psi_camx_op,.true.,mpi_camx_op,info) + if (info == 0) call mpi_op_create(psi_camn_op,.true.,mpi_camn_op,info) + if (info == 0) call mpi_op_create(psi_zamx_op,.true.,mpi_zamx_op,info) + if (info == 0) call mpi_op_create(psi_zamn_op,.true.,mpi_zamn_op,info) + if (info == 0) call mpi_op_create(psi_snrm2_op,.true.,mpi_snrm2_op,info) + if (info == 0) call mpi_op_create(psi_dnrm2_op,.true.,mpi_dnrm2_op,info) + + end subroutine psi_register_mpi_extras + + + subroutine psb_init(ictxt,np,basectxt,ids) + use psi_comm_buffers_mod + use psb_const_mod + use psb_error_mod +! !$ use psb_rsb_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(out) :: ictxt + integer, intent(in), optional :: np, basectxt, ids(:) + + + integer :: i, isnullcomm + integer, allocatable :: iids(:) + logical :: initialized + integer :: np_, npavail, iam, info, basecomm, basegroup, newgroup + character(len=20), parameter :: name='psb_init' +#if defined(SERIAL_MPI) + ictxt = nctxt + nctxt = nctxt + 1 + + call psi_register_mpi_extras(info) + call psi_get_sizes() + +#else + call mpi_initialized(initialized,info) + if ((.not.initialized).or.(info /= mpi_success)) then + call mpi_init(info) + if (info /= mpi_success) then + write(0,*) 'Error in initalizing MPI, bailing out',info + stop + end if + end if + + if (present(basectxt)) then + basecomm = basectxt + else + basecomm = mpi_comm_world + end if + + if (present(np)) then + if (np < 1) then + info=psb_err_initerror_neugh_procs_ + call psb_errpush(info,name) + call psb_error() + ictxt = mpi_comm_null + return + endif + call mpi_comm_size(basecomm,np_,info) + if (np_ < np) then + info=psb_err_initerror_neugh_procs_ + call psb_errpush(info,name) + call psb_error() + ictxt = mpi_comm_null + return + endif + call mpi_comm_group(basecomm,basegroup,info) + if (present(ids)) then + if (size(ids)np_)) then + write(0,*) 'Error in init: invalid ransk in input' + ictxt = mpi_comm_null + return + end if + end do + call mpi_group_incl(basegroup,np,ids,newgroup,info) + if (info /= mpi_success) then + ictxt = mpi_comm_null + return + endif + else + allocate(iids(np),stat=info) + if (info /= 0) then + ictxt = mpi_comm_null + return + endif + do i=1, np + iids(i) = i-1 + end do + call mpi_group_incl(basegroup,np,iids,newgroup,info) + if (info /= mpi_success) then + ictxt = mpi_comm_null + return + endif + deallocate(iids) + end if + call mpi_comm_create(basecomm,newgroup,ictxt,info) + + else + if (basecomm /= mpi_comm_null) then + call mpi_comm_dup(basecomm,ictxt,info) + else + ictxt = mpi_comm_null + end if + endif + call psi_register_mpi_extras(info) + call psi_get_sizes() + if (ictxt == mpi_comm_null) return +#endif + +! !$ call psb_rsb_init(info) +! !$ if (info.ne.psb_rsb_const_success) then +! !$ if (info.eq.psb_rsb_const_not_available) then +! !$ info=psb_success_ ! rsb is not present +! !$ else +! !$ ! rsb failed to initialize, and we issue an internal error. +! !$ ! or shall we tolerate this ? +! !$ info=psb_err_internal_error_ +! !$ call psb_errpush(info,name) +! !$ call psb_error(ictxt) +! !$ endif +! !$ endif + + end subroutine psb_init + + subroutine psb_exit(ictxt,close) + use psi_comm_buffers_mod +! !$ use psb_rsb_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + logical, intent(in), optional :: close + logical :: close_ + integer :: info + character(len=20), parameter :: name='psb_exit' + + info = 0 + if (present(close)) then + close_ = close + else + close_ = .true. + end if +! !$ if (close_) call psb_rsb_exit(info) +! !$ if (info.ne.psb_rsb_const_success) then +! !$ if (info.eq.psb_rsb_const_not_available) then +! !$ info=psb_success_ ! rsb is not present +! !$ else +! !$ info=psb_err_internal_error_ ! rsb failed to exit, and we issue an internal error. or shall we tolerate this ? +! !$ call psb_errpush(info,name) +! !$ call psb_error(ictxt) +! !$ endif +! !$ endif +#if !defined(SERIAL_MPI) + if (close_) then + call psb_close_all_context(psb_mesg_queue) + else + call psb_close_context(psb_mesg_queue,ictxt) + end if + if ((ictxt /= mpi_comm_null).and.(ictxt /= mpi_comm_world)) then + call mpi_comm_Free(ictxt,info) + end if + + if (close_) call mpi_finalize(info) +#endif + + + end subroutine psb_exit + + + subroutine psb_barrier(ictxt) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + + integer :: info +#if !defined(SERIAL_MPI) + if (ictxt /= mpi_comm_null) then + call mpi_barrier(ictxt, info) + end if +#endif + + end subroutine psb_barrier + + function psb_wtime() + use psb_const_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + real(psb_dpk_) :: psb_wtime + + psb_wtime = mpi_wtime() + end function psb_wtime + + subroutine psb_abort(ictxt,errc) + use psi_comm_buffers_mod + + integer, intent(in) :: ictxt + integer, intent(in), optional :: errc + + integer :: code, info + + if (present(errc)) then + code = errc + else + core = -1 + endif + +#if defined(SERIAL_MPI) + stop code +#else + call mpi_abort(ictxt,code,info) +#endif + + end subroutine psb_abort + + + subroutine psb_info(ictxt,iam,np) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer, intent(in) :: ictxt + integer, intent(out) :: iam, np + integer :: info + +#if defined(SERIAL_MPI) + iam = 0 + np = 1 +#else + iam = -1 + np = -1 + if (ictxt /= mpi_comm_null) then + call mpi_comm_size(ictxt,np,info) + if (info /= mpi_success) np = -1 + call mpi_comm_rank(ictxt,iam,info) + if (info /= mpi_success) iam = -1 + end if +#endif + + end subroutine psb_info + + + + subroutine psb_set_coher(ictxt,isvch) + integer :: ictxt, isvch + ! Ensure global repeatability for convergence checks. + ! Do nothing. Obsolete. + end subroutine psb_set_coher + + subroutine psb_restore_coher(ictxt,isvch) + integer :: ictxt, isvch + ! Ensure global coherence for convergence checks. + ! Do nothing. Obsolete. + + end subroutine psb_restore_coher + + subroutine psb_get_mpicomm(ictxt,comm) + integer :: ictxt, comm + + comm = ictxt + end subroutine psb_get_mpicomm + + subroutine psb_get_rank(rank,ictxt,id) + integer :: rank,ictxt,id + + rank = id + end subroutine psb_get_rank + + + ! !!!!!!!!!!!!!!!!!!!!!! + ! + ! Base binary operations + ! + ! !!!!!!!!!!!!!!!!!!!!!! + subroutine psi_iamx_op(inv, outv,len,type) + integer :: inv(*),outv(*) + integer :: len,type + integer :: i + + do i=1, len + if (abs(inv(i)) > abs(outv(i))) outv(i) = inv(i) + end do + end subroutine psi_iamx_op + + subroutine psi_iamn_op(inv, outv,len,type) + integer :: inv(*),outv(*) + integer :: len,type + integer :: i + do i=1, len + if (abs(inv(i)) < abs(outv(i))) outv(i) = inv(i) + end do + end subroutine psi_iamn_op + + subroutine psi_i8amx_op(inv, outv,len,type) + integer(psb_long_int_k_) :: inv(*),outv(*) + integer :: len,type + integer :: i + + do i=1, len + if (abs(inv(i)) > abs(outv(i))) outv(i) = inv(i) + end do + end subroutine psi_i8amx_op + + subroutine psi_i8amn_op(inv, outv,len,type) + integer(psb_long_int_k_) :: inv(*),outv(*) + integer :: len,type + integer :: i + if (type /= mpi_integer8) then + write(0,*) 'Invalid type !!!' + end if + do i=1, len + if (abs(inv(i)) < abs(outv(i))) outv(i) = inv(i) + end do + end subroutine psi_i8amn_op + + subroutine psi_samx_op(vin,vinout,len,itype) + integer, intent(in) :: len, itype + real(psb_spk_), intent(in) :: vin(len) + real(psb_spk_), intent(inout) :: vinout(len) + + integer :: i + do i=1, len + if (abs(vinout(i)) < abs(vin(i))) vinout(i) = vin(i) + end do + end subroutine psi_samx_op + + subroutine psi_samn_op(vin,vinout,len,itype) + integer, intent(in) :: len, itype + real(psb_spk_), intent(in) :: vin(len) + real(psb_spk_), intent(inout) :: vinout(len) + + integer :: i + do i=1, len + if (abs(vinout(i)) > abs(vin(i))) vinout(i) = vin(i) + end do + end subroutine psi_samn_op + + subroutine psi_damx_op(vin,vinout,len,itype) + integer, intent(in) :: len, itype + real(psb_dpk_), intent(in) :: vin(len) + real(psb_dpk_), intent(inout) :: vinout(len) + + integer :: i + do i=1, len + if (abs(vinout(i)) < abs(vin(i))) vinout(i) = vin(i) + end do + end subroutine psi_damx_op + + subroutine psi_damn_op(vin,vinout,len,itype) + integer, intent(in) :: len, itype + real(psb_dpk_), intent(in) :: vin(len) + real(psb_dpk_), intent(inout) :: vinout(len) + + integer :: i + do i=1, len + if (abs(vinout(i)) > abs(vin(i))) vinout(i) = vin(i) + end do + end subroutine psi_damn_op + + subroutine psi_camx_op(vin,vinout,len,itype) + integer, intent(in) :: len, itype + complex(psb_spk_), intent(in) :: vin(len) + complex(psb_spk_), intent(inout) :: vinout(len) + + integer :: i + do i=1, len + if (abs(vinout(i)) < abs(vin(i))) vinout(i) = vin(i) + end do + end subroutine psi_camx_op + + subroutine psi_camn_op(vin,vinout,len,itype) + integer, intent(in) :: len, itype + complex(psb_spk_), intent(in) :: vin(len) + complex(psb_spk_), intent(inout) :: vinout(len) + + integer :: i + do i=1, len + if (abs(vinout(i)) > abs(vin(i))) vinout(i) = vin(i) + end do + end subroutine psi_camn_op + + subroutine psi_zamx_op(vin,vinout,len,itype) + integer, intent(in) :: len, itype + complex(psb_dpk_), intent(in) :: vin(len) + complex(psb_dpk_), intent(inout) :: vinout(len) + + integer :: i + do i=1, len + if (abs(vinout(i)) < abs(vin(i))) vinout(i) = vin(i) + end do + end subroutine psi_zamx_op + + subroutine psi_zamn_op(vin,vinout,len,itype) + integer, intent(in) :: len, itype + complex(psb_dpk_), intent(in) :: vin(len) + complex(psb_dpk_), intent(inout) :: vinout(len) + + integer :: i + do i=1, len + if (abs(vinout(i)) > abs(vin(i))) vinout(i) = vin(i) + end do + end subroutine psi_zamn_op + + subroutine psi_snrm2_op(vin,vinout,len,itype) + implicit none + integer, intent(in) :: len, itype + real(psb_spk_), intent(in) :: vin(len) + real(psb_spk_), intent(inout) :: vinout(len) + + integer :: i + real(psb_spk_) :: w, z + do i=1, len + w = max( vin(i), vinout(i) ) + z = min( vin(i), vinout(i) ) + if ( z == szero ) then + vinout(i) = w + else + vinout(i) = w*sqrt( sone+( z / w )**2 ) + end if + end do + end subroutine psi_snrm2_op + + subroutine psi_dnrm2_op(vin,vinout,len,itype) + implicit none + integer, intent(in) :: len, itype + real(psb_dpk_), intent(in) :: vin(len) + real(psb_dpk_), intent(inout) :: vinout(len) + + integer :: i + real(psb_dpk_) :: w, z + do i=1, len + w = max( vin(i), vinout(i) ) + z = min( vin(i), vinout(i) ) + if ( z == dzero ) then + vinout(i) = w + else + vinout(i) = w*sqrt( done+( z / w )**2 ) + end if + end do + end subroutine psi_dnrm2_op + +end module psi_penv_mod diff --git a/base/modules/psi_reduce_mod.F90 b/base/modules/psi_reduce_mod.F90 new file mode 100644 index 00000000..4503f224 --- /dev/null +++ b/base/modules/psi_reduce_mod.F90 @@ -0,0 +1,3399 @@ +module psi_reduce_mod + use psi_penv_mod + interface psb_max + module procedure psb_imaxs, psb_imaxv, psb_imaxm,& + & psb_smaxs, psb_smaxv, psb_smaxm,& + & psb_dmaxs, psb_dmaxv, psb_dmaxm + end interface +#if !defined(LONG_INTEGERS) + interface psb_max + module procedure psb_i8maxs, psb_i8maxv, psb_i8maxm + end interface +#endif + + interface psb_min + module procedure psb_imins, psb_iminv, psb_iminm,& + & psb_smins, psb_sminv, psb_sminm,& + & psb_dmins, psb_dminv, psb_dminm + end interface +#if !defined(LONG_INTEGERS) + interface psb_min + module procedure psb_i8mins, psb_i8minv, psb_i8minm + end interface +#endif + + + interface psb_amx + module procedure psb_iamxs, psb_iamxv, psb_iamxm,& + & psb_samxs, psb_samxv, psb_samxm,& + & psb_camxs, psb_camxv, psb_camxm,& + & psb_damxs, psb_damxv, psb_damxm,& + & psb_zamxs, psb_zamxv, psb_zamxm + end interface +#if !defined(LONG_INTEGERS) + interface psb_amx + module procedure psb_i8amxs, psb_i8amxv, psb_i8amxm + end interface +#endif + + interface psb_amn + module procedure psb_iamns, psb_iamnv, psb_iamnm,& + & psb_samns, psb_samnv, psb_samnm,& + & psb_camns, psb_camnv, psb_camnm,& + & psb_damns, psb_damnv, psb_damnm,& + & psb_zamns, psb_zamnv, psb_zamnm + end interface +#if !defined(LONG_INTEGERS) + interface psb_amn + module procedure psb_i8amns, psb_i8amnv, psb_i8amnm + end interface +#endif + + + interface psb_sum + module procedure psb_isums, psb_isumv, psb_isumm,& + & psb_ssums, psb_ssumv, psb_ssumm,& + & psb_csums, psb_csumv, psb_csumm,& + & psb_dsums, psb_dsumv, psb_dsumm,& + & psb_zsums, psb_zsumv, psb_zsumm + end interface +#if !defined(LONG_INTEGERS) + interface psb_sum + module procedure psb_i8sums, psb_i8sumv, psb_i8summ + end interface +#endif + + + interface psb_nrm2 + module procedure psb_s_nrm2s, psb_s_nrm2v,& + & psb_d_nrm2s, psb_d_nrm2v + end interface + + +contains + + ! !!!!!!!!!!!!!!!!!!!!!! + ! + ! Reduction operations + ! + ! !!!!!!!!!!!!!!!!!!!!!! + + + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! MAX + ! + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine psb_imaxs(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer, intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_, dat_ + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_integer,mpi_max,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_integer,mpi_max,root_,ictxt,info) + dat = dat_ + endif +#endif + end subroutine psb_imaxs + + subroutine psb_imaxv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer, intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + integer, allocatable :: dat_(:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_=dat + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & psb_mpi_integer,mpi_max,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_integer,mpi_max,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),psb_mpi_integer,mpi_max,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_imaxv + + subroutine psb_imaxm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer, intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + integer, allocatable :: dat_(:,:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_=dat + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & psb_mpi_integer,mpi_max,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_integer,mpi_max,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),psb_mpi_integer,mpi_max,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_imaxm + +#if !defined(LONG_INTEGERS) + subroutine psb_i8maxs(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_long_int_k_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + integer(psb_long_int_k_) :: dat_ + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_integer8,mpi_max,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_integer8,mpi_max,root_,ictxt,info) + dat = dat_ + endif +#endif + end subroutine psb_i8maxs + + subroutine psb_i8maxv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_long_int_k_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + integer(psb_long_int_k_), allocatable :: dat_(:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_=dat + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & mpi_integer8,mpi_max,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),mpi_integer8,mpi_max,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_integer8,mpi_max,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i8maxv + + subroutine psb_i8maxm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_long_int_k_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + integer(psb_long_int_k_), allocatable :: dat_(:,:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_=dat + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & mpi_integer8,mpi_max,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),mpi_integer8,mpi_max,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_integer8,mpi_max,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i8maxm + +#endif + + + + subroutine psb_smaxs(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + real(psb_spk_) :: dat_ + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_real,mpi_max,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_real,mpi_max,root_,ictxt,info) + dat = dat_ + endif +#endif + end subroutine psb_smaxs + + subroutine psb_smaxv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_spk_), allocatable :: dat_(:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + if (info == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_max,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_max,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_max,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_smaxv + + subroutine psb_smaxm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_spk_), allocatable :: dat_(:,:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + if (info == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_max,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_max,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_max,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_smaxm + + subroutine psb_dmaxs(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + real(psb_dpk_) :: dat_ + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_double_precision,mpi_max,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_double_precision,mpi_max,root_,ictxt,info) + dat = dat_ + endif +#endif + end subroutine psb_dmaxs + + subroutine psb_dmaxv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_dpk_), allocatable :: dat_(:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + if (info == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),mpi_double_precision,& + & mpi_max,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_max,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,mpi_max,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_dmaxv + + subroutine psb_dmaxm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_dpk_), allocatable :: dat_(:,:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + if (info == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),mpi_double_precision,mpi_max,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_max,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,mpi_max,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_dmaxm + + + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! MIN + ! + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine psb_imins(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer, intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_, dat_ + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_integer,mpi_min,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_integer,mpi_min,root_,ictxt,info) + dat = dat_ + endif +#endif + end subroutine psb_imins + + subroutine psb_iminv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer, intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + integer, allocatable :: dat_(:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_=dat + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & psb_mpi_integer,mpi_min,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_integer,mpi_min,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),psb_mpi_integer,mpi_min,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_iminv + + subroutine psb_iminm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer, intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + integer, allocatable :: dat_(:,:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_=dat + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & psb_mpi_integer,mpi_min,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_integer,mpi_min,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),psb_mpi_integer,mpi_min,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_iminm + +#if !defined(LONG_INTEGERS) + subroutine psb_i8mins(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_long_int_k_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + integer(psb_long_int_k_) :: dat_ + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_integer8,mpi_min,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_integer8,mpi_min,root_,ictxt,info) + dat = dat_ + endif +#endif + end subroutine psb_i8mins + + subroutine psb_i8minv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_long_int_k_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + integer(psb_long_int_k_), allocatable :: dat_(:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_=dat + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & mpi_integer8,mpi_min,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),mpi_integer8,mpi_min,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_integer8,mpi_min,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i8minv + + subroutine psb_i8minm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_long_int_k_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + integer(psb_long_int_k_), allocatable :: dat_(:,:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_=dat + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & mpi_integer8,mpi_min,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),mpi_integer8,mpi_min,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_integer8,mpi_min,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i8minm + +#endif + + + + subroutine psb_smins(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + real(psb_spk_) :: dat_ + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_real,mpi_min,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_real,mpi_min,root_,ictxt,info) + dat = dat_ + endif +#endif + end subroutine psb_smins + + subroutine psb_sminv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_spk_), allocatable :: dat_(:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + if (info == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_min,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_min,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_min,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_sminv + + subroutine psb_sminm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_spk_), allocatable :: dat_(:,:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + if (info == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_min,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_min,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_min,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_sminm + + subroutine psb_dmins(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + real(psb_dpk_) :: dat_ + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_double_precision,mpi_min,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_double_precision,mpi_min,root_,ictxt,info) + dat = dat_ + endif +#endif + end subroutine psb_dmins + + subroutine psb_dminv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_dpk_), allocatable :: dat_(:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + if (info == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),mpi_double_precision,& + & mpi_min,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_min,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,mpi_min,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_dminv + + subroutine psb_dminm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_dpk_), allocatable :: dat_(:,:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + if (info == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),mpi_double_precision,mpi_min,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_min,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,mpi_min,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_dminm + + + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! AMX: maximum absolute value + ! + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + subroutine psb_iamxs(ictxt,dat,root) + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer, intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + integer(psb_long_int_k_) :: dat_ + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_integer,mpi_iamx_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_integer,mpi_iamx_op,root_,ictxt,info) + dat = dat_ + endif + +#endif + end subroutine psb_iamxs + + subroutine psb_iamxv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer, intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + integer, allocatable :: dat_(:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_=dat + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & psb_mpi_integer,mpi_iamx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_integer,mpi_iamx_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),psb_mpi_integer,mpi_iamx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_iamxv + + subroutine psb_iamxm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer, intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + integer, allocatable :: dat_(:,:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_=dat + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & psb_mpi_integer,mpi_iamx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_integer,mpi_iamx_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),psb_mpi_integer,mpi_iamx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_iamxm + + +#if !defined(LONG_INTEGERS) + subroutine psb_i8amxs(ictxt,dat,root) + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_long_int_k_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + integer(psb_long_int_k_) :: dat_ + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_integer8,mpi_i8amx_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_integer8,mpi_i8amx_op,root_,ictxt,info) + dat = dat_ + endif + +#endif + end subroutine psb_i8amxs + + subroutine psb_i8amxv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_long_int_k_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + integer(psb_long_int_k_), allocatable :: dat_(:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_=dat + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & mpi_integer8,mpi_i8amx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),mpi_integer8,mpi_i8amx_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_integer8,mpi_i8amx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i8amxv + + subroutine psb_i8amxm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_long_int_k_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + integer(psb_long_int_k_), allocatable :: dat_(:,:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_=dat + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & mpi_integer8,mpi_i8amx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),mpi_integer8,mpi_i8amx_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_integer8,mpi_i8amx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i8amxm + +#endif + + + + subroutine psb_samxs(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + real(psb_spk_) :: dat_ + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_real,mpi_samx_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_real,mpi_samx_op,root_,ictxt,info) + dat = dat_ + endif +#endif + end subroutine psb_samxs + + subroutine psb_samxv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_spk_), allocatable :: dat_(:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + if (info == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_samx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_samx_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_samx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_samxv + + subroutine psb_samxm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_spk_), allocatable :: dat_(:,:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + if (info == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_samx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_samx_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_samx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_samxm + + subroutine psb_damxs(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + real(psb_dpk_) :: dat_ + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_double_precision,mpi_damx_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_double_precision,mpi_damx_op,root_,ictxt,info) + dat = dat_ + endif +#endif + end subroutine psb_damxs + + subroutine psb_damxv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_dpk_), allocatable :: dat_(:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + if (info == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),mpi_double_precision,& + & mpi_damx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_damx_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,mpi_damx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_damxv + + subroutine psb_damxm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_dpk_), allocatable :: dat_(:,:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + if (info == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),mpi_double_precision,mpi_damx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_damx_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,mpi_damx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_damxm + + + subroutine psb_camxs(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + complex(psb_spk_) :: dat_ + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_complex,mpi_camx_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_complex,mpi_camx_op,root_,ictxt,info) + dat = dat_ + endif +#endif + end subroutine psb_camxs + + subroutine psb_camxv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + complex(psb_spk_), allocatable :: dat_(:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + if (info == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),mpi_complex,mpi_camx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_complex,mpi_camx_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_complex,mpi_camx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_camxv + + subroutine psb_camxm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + complex(psb_spk_), allocatable :: dat_(:,:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + if (info == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),mpi_complex,mpi_camx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_complex,mpi_camx_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_complex,mpi_camx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_camxm + + subroutine psb_zamxs(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + complex(psb_dpk_) :: dat_ + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_double_complex,mpi_zamx_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_double_complex,mpi_zamx_op,root_,ictxt,info) + dat = dat_ + endif +#endif + end subroutine psb_zamxs + + subroutine psb_zamxv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + complex(psb_dpk_), allocatable :: dat_(:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + if (info == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),mpi_double_complex,& + & mpi_zamx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_double_complex,mpi_zamx_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_double_complex,mpi_zamx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_zamxv + + subroutine psb_zamxm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + complex(psb_dpk_), allocatable :: dat_(:,:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + if (info == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),mpi_double_complex,mpi_zamx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_double_complex,mpi_zamx_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_double_complex,mpi_zamx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_zamxm + + + + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! AMN: minimum absolute value + ! + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine psb_iamns(ictxt,dat,root) + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer, intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + integer(psb_long_int_k_) :: dat_ + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_integer,mpi_iamn_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_integer,mpi_iamn_op,root_,ictxt,info) + dat = dat_ + endif + +#endif + end subroutine psb_iamns + + subroutine psb_iamnv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer, intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + integer, allocatable :: dat_(:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_=dat + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & psb_mpi_integer,mpi_iamn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_integer,mpi_iamn_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),psb_mpi_integer,mpi_iamn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_iamnv + + subroutine psb_iamnm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer, intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + integer, allocatable :: dat_(:,:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_=dat + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & psb_mpi_integer,mpi_iamn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_integer,mpi_iamn_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),psb_mpi_integer,mpi_iamn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_iamnm + + +#if !defined(LONG_INTEGERS) + subroutine psb_i8amns(ictxt,dat,root) + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_long_int_k_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + integer(psb_long_int_k_) :: dat_ + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_integer8,mpi_i8amn_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_integer8,mpi_i8amn_op,root_,ictxt,info) + dat = dat_ + endif + +#endif + end subroutine psb_i8amns + + subroutine psb_i8amnv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_long_int_k_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + integer(psb_long_int_k_), allocatable :: dat_(:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_=dat + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & mpi_integer8,mpi_i8amn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),mpi_integer8,mpi_i8amn_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_integer8,mpi_i8amn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i8amnv + + subroutine psb_i8amnm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_long_int_k_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + integer(psb_long_int_k_), allocatable :: dat_(:,:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_=dat + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & mpi_integer8,mpi_i8amn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),mpi_integer8,mpi_i8amn_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_integer8,mpi_i8amn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i8amnm + +#endif + + + + subroutine psb_samns(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + real(psb_spk_) :: dat_ + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_real,mpi_samn_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_real,mpi_samn_op,root_,ictxt,info) + dat = dat_ + endif +#endif + end subroutine psb_samns + + subroutine psb_samnv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_spk_), allocatable :: dat_(:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + if (info == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_samn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_samn_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_samn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_samnv + + subroutine psb_samnm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_spk_), allocatable :: dat_(:,:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + if (info == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_samn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_samn_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_samn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_samnm + + subroutine psb_damns(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + real(psb_dpk_) :: dat_ + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_double_precision,mpi_damn_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_double_precision,mpi_damn_op,root_,ictxt,info) + dat = dat_ + endif +#endif + end subroutine psb_damns + + subroutine psb_damnv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_dpk_), allocatable :: dat_(:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + if (info == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),mpi_double_precision,& + & mpi_damn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_damn_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,mpi_damn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_damnv + + subroutine psb_damnm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_dpk_), allocatable :: dat_(:,:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + if (info == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),mpi_double_precision,mpi_damn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_damn_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,mpi_damn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_damnm + + + subroutine psb_camns(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + complex(psb_spk_) :: dat_ + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_complex,mpi_camn_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_complex,mpi_camn_op,root_,ictxt,info) + dat = dat_ + endif +#endif + end subroutine psb_camns + + subroutine psb_camnv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + complex(psb_spk_), allocatable :: dat_(:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + if (info == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),mpi_complex,mpi_camn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_complex,mpi_camn_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_complex,mpi_camn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_camnv + + subroutine psb_camnm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + complex(psb_spk_), allocatable :: dat_(:,:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + if (info == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),mpi_complex,mpi_camn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_complex,mpi_camn_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_complex,mpi_camn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_camnm + + subroutine psb_zamns(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + complex(psb_dpk_) :: dat_ + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_double_complex,mpi_zamn_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_double_complex,mpi_zamn_op,root_,ictxt,info) + dat = dat_ + endif +#endif + end subroutine psb_zamns + + subroutine psb_zamnv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + complex(psb_dpk_), allocatable :: dat_(:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + if (info == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),mpi_double_complex,& + & mpi_zamn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_double_complex,mpi_zamn_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_double_complex,mpi_zamn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_zamnv + + subroutine psb_zamnm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + complex(psb_dpk_), allocatable :: dat_(:,:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + if (info == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),mpi_double_complex,mpi_zamn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_double_complex,mpi_zamn_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_double_complex,mpi_zamn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_zamnm + + + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! SUM + ! + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine psb_isums(ictxt,dat,root) + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer, intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + integer(psb_long_int_k_) :: dat_ + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_integer,mpi_sum,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_integer,mpi_sum,root_,ictxt,info) + dat = dat_ + endif + +#endif + end subroutine psb_isums + + subroutine psb_isumv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer, intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + integer, allocatable :: dat_(:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_=dat + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & psb_mpi_integer,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_integer,mpi_sum,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),psb_mpi_integer,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_isumv + + subroutine psb_isumm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer, intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + integer, allocatable :: dat_(:,:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_=dat + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & psb_mpi_integer,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_integer,mpi_sum,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),psb_mpi_integer,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_isumm + + +#if !defined(LONG_INTEGERS) + subroutine psb_i8sums(ictxt,dat,root) + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_long_int_k_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + integer(psb_long_int_k_) :: dat_ + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_integer8,mpi_sum,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_integer8,mpi_sum,root_,ictxt,info) + dat = dat_ + endif + +#endif + end subroutine psb_i8sums + + subroutine psb_i8sumv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_long_int_k_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + integer(psb_long_int_k_), allocatable :: dat_(:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_=dat + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & mpi_integer8,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),mpi_integer8,mpi_sum,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_integer8,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i8sumv + + subroutine psb_i8summ(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + integer(psb_long_int_k_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + integer(psb_long_int_k_), allocatable :: dat_(:,:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_=dat + if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & mpi_integer8,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),mpi_integer8,mpi_sum,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_integer8,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i8summ + +#endif + + + + subroutine psb_ssums(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + real(psb_spk_) :: dat_ + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_real,mpi_sum,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_real,mpi_sum,root_,ictxt,info) + dat = dat_ + endif +#endif + end subroutine psb_ssums + + subroutine psb_ssumv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_spk_), allocatable :: dat_(:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + if (info == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_sum,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_ssumv + + subroutine psb_ssumm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_spk_), allocatable :: dat_(:,:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + if (info == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),mpi_real,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_real,mpi_sum,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_real,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_ssumm + + subroutine psb_dsums(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + real(psb_dpk_) :: dat_ + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_double_precision,mpi_sum,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_double_precision,mpi_sum,root_,ictxt,info) + dat = dat_ + endif +#endif + end subroutine psb_dsums + + subroutine psb_dsumv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_dpk_), allocatable :: dat_(:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + if (info == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),mpi_double_precision,& + & mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_sum,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_dsumv + + subroutine psb_dsumm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_dpk_), allocatable :: dat_(:,:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + if (info == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),mpi_double_precision,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,mpi_sum,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_dsumm + + + subroutine psb_csums(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + complex(psb_spk_) :: dat_ + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_complex,mpi_sum,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_complex,mpi_sum,root_,ictxt,info) + dat = dat_ + endif +#endif + end subroutine psb_csums + + subroutine psb_csumv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + complex(psb_spk_), allocatable :: dat_(:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + if (info == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),mpi_complex,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_complex,mpi_sum,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_complex,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_csumv + + subroutine psb_csumm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + complex(psb_spk_), allocatable :: dat_(:,:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + if (info == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),mpi_complex,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_complex,mpi_sum,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_complex,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_csumm + + subroutine psb_zsums(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + complex(psb_dpk_) :: dat_ + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_double_complex,mpi_sum,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_double_complex,mpi_sum,root_,ictxt,info) + dat = dat_ + endif +#endif + end subroutine psb_zsums + + subroutine psb_zsumv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + complex(psb_dpk_), allocatable :: dat_(:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + if (info == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),mpi_double_complex,& + & mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_double_complex,mpi_sum,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_double_complex,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_zsumv + + subroutine psb_zsumm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:,:) + integer, intent(in), optional :: root + integer :: root_ + complex(psb_dpk_), allocatable :: dat_(:,:) + integer :: iam, np, info + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + if (info == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),mpi_double_complex,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_double_complex,mpi_sum,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_double_complex,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_zsumm + + ! !!!!!!!!!!!! + ! + ! Norm 2 + ! + ! !!!!!!!!!!!! + subroutine psb_s_nrm2s(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + real(psb_spk_) :: dat_ + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_real,mpi_snrm2_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_real,mpi_snrm2_op,root_,ictxt,info) + dat = dat_ + endif +#endif + end subroutine psb_s_nrm2s + + subroutine psb_d_nrm2s(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + integer, intent(in), optional :: root + integer :: root_ + real(psb_dpk_) :: dat_ + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,mpi_double_precision,mpi_dnrm2_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,mpi_double_precision,mpi_dnrm2_op,root_,ictxt,info) + dat = dat_ + endif +#endif + end subroutine psb_d_nrm2s + + subroutine psb_s_nrm2v(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_spk_), allocatable :: dat_(:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + if (info == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),mpi_real,& + & mpi_snrm2_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_real,& + & mpi_snrm2_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_real,& + & mpi_snrm2_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_s_nrm2v + + subroutine psb_d_nrm2v(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer, intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + integer, intent(in), optional :: root + integer :: root_ + real(psb_dpk_), allocatable :: dat_(:) + integer :: iam, np, info + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + if (info == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),mpi_double_precision,& + & mpi_dnrm2_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,info) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),mpi_double_precision,& + & mpi_dnrm2_op,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),mpi_double_precision,& + & mpi_dnrm2_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_d_nrm2v + + +end module psi_reduce_mod