From 30dc67fbc0fc18a36b693912ffb1cdc04bf16e04 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 1 Nov 2006 10:06:54 +0000 Subject: [PATCH] New swap data code. --- src/comm/psb_dhalo.f90 | 4 +- src/internals/ctof_blacs.h | 344 --------- src/internals/psblas.h | 316 --------- src/internals/psi_crea_index.f90 | 26 +- src/internals/psi_crea_ovr_elem.f90 | 152 ++-- src/internals/psi_desc_index.f90 | 69 +- src/internals/psi_dswapdata.f90 | 987 ++++++++++++-------------- src/internals/psi_dswaptran.f90 | 1025 ++++++++++++--------------- src/internals/psi_extrct_dl.f | 2 +- src/internals/psi_iswapdata.f90 | 991 ++++++++++++-------------- src/internals/psi_iswaptran.f90 | 1013 ++++++++++++-------------- src/internals/psi_zswapdata.f90 | 987 ++++++++++++-------------- src/internals/psi_zswaptran.f90 | 1022 ++++++++++++-------------- src/modules/Makefile | 12 +- src/modules/psb_const.fh | 10 +- src/modules/psb_const_mod.f90 | 109 ++- src/modules/psb_desc_type.f90 | 59 +- src/modules/psb_error_mod.f90 | 6 +- src/modules/psb_realloc_mod.f90 | 287 +++++++- src/modules/psb_spmat_type.f90 | 43 +- src/modules/psi_mod.f90 | 108 ++- src/prec/psb_dbldaggrmat.f90 | 22 + src/serial/dp/check_dim.f | 2 +- src/serial/dp/dcoco.f | 2 +- src/serial/dp/dcocr.f | 2 +- src/serial/dp/dcrco.f | 2 +- src/serial/dp/dcrjd.f | 2 +- src/serial/dp/dcsrp1.f | 2 +- src/serial/dp/dgind_tri.f | 2 +- src/serial/dp/dgindex.f | 2 +- src/serial/dp/djdco.f | 2 +- src/serial/dp/djdcox.f | 2 +- src/serial/dp/gen_block.f | 2 +- src/serial/dp/partition.f | 2 +- src/serial/dp/zcoco.f | 2 +- src/serial/dp/zcocr.f | 2 +- src/serial/dp/zcrco.f | 2 +- src/serial/dp/zcrjd.f | 2 +- src/serial/dp/zgind_tri.f | 2 +- src/serial/dp/zgindex.f | 2 +- src/serial/f77/dcsmm.f | 2 +- src/serial/jad/djadnr.f | 2 +- src/serial/jad/djadrws.f | 2 +- src/tools/psb_cdasb.f90 | 100 +-- src/tools/psb_cdcpy.f90 | 165 +---- src/tools/psb_cddec.f90 | 38 +- src/tools/psb_cdfree.f90 | 28 + src/tools/psb_cdprt.f90 | 4 +- src/tools/psb_cdrep.f90 | 38 +- src/tools/psb_dcdovr.f90 | 14 +- src/tools/psb_dcdovrbld.f90 | 150 +--- src/tools/psb_dsphalo.f90 | 3 +- src/tools/psb_zcdovr.f90 | 16 +- src/tools/psb_zcdovrbld.f90 | 153 +--- src/tools/psb_zsphalo.f90 | 3 +- 55 files changed, 3622 insertions(+), 4726 deletions(-) delete mode 100644 src/internals/ctof_blacs.h delete mode 100644 src/internals/psblas.h diff --git a/src/comm/psb_dhalo.f90 b/src/comm/psb_dhalo.f90 index 2db27c416..07de784ec 100644 --- a/src/comm/psb_dhalo.f90 +++ b/src/comm/psb_dhalo.f90 @@ -84,7 +84,7 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode) call psb_errpush(info,name) goto 9999 endif - + ix = 1 if (present(jx)) then ijx = jx @@ -184,7 +184,7 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode) end if if(info.ne.0) then - ch_err='PSI_dSwap...' + ch_err='PSI_dSwapdata' call psb_errpush(4010,name,a_err=ch_err) goto 9999 end if diff --git a/src/internals/ctof_blacs.h b/src/internals/ctof_blacs.h deleted file mode 100644 index cf5f2288a..000000000 --- a/src/internals/ctof_blacs.h +++ /dev/null @@ -1,344 +0,0 @@ -/* - * Parallel Sparse BLAS v2.0 - * (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata - * Alfredo Buttari University of Rome Tor Vergata - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions - * are met: - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions, and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * 3. The name of the PSBLAS group or the names of its contributors may - * not be used to endorse or promote products derived from this - * software without specific written permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - * ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR - * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS - * BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR - * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF - * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS - * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN - * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) - * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - * POSSIBILITY OF SUCH DAMAGE. - * - */ -/* This header file replaces every call to a BLACS routine by C interface - with the same call performed by Fortran interface */ - -#ifndef CTOF_BLACS -#define CTOF_BLACS -#endif - -/* Variables necessary for invocations where - constant arguments are used */ - -static int i1, i2, i3, i4, i5, i6, i7; - -/* Support routines: - Initialization */ - -#define Cblacs_pinfo(mypnum, nprocs) \ - blacs_pinfo_(mypnum, nprocs) -#define Cblacs_setup(mypnum, nprocs) \ - blacs_setup_(mypnum, nprocs) -#define Cblacs_get(ictxt, what, val) \ - {i1 = ictxt; i2 = what; \ - blacs_get_(&i1, &i2,val);} -#define Cblacs_set(ictxt, what, val) \ - {i1 = ictxt; i2 = what; \ - blacs_set_(&i1, &i2, &val);} -#define Cblacs_gridinit(ictxt, order, nprow, npcol) \ - {i1 = nprow; i2 = npcol; \ - blacs_gridinit_(ictxt, order, &i1, &i2);} -#define Cblacs_gridmap(ictxt, pmap, ldpmap, nprow, npcol) \ - {i1 = ldpmap; i2 = nprow; i3 = npcol; \ - blacs_gridmap_(ictxt, pmap, &i1, &i2, &i3);} - -/* Support routines: - Destruction */ - -#define Cblacs_freebuff(ictxt, wait) \ - {i1 = ictxt; i2 = wait; \ - blacs_freebuff_(&i1, &i2);} -#define Cblacs_gridexit(ictxt) \ - {i1 = ictxt; \ - blacs_gridexit_(&i1);} -#define Cblacs_abort(ictxt, errornum) \ - {i1 = ictxt; i2 = errornum; \ - blacs_abort_(&i1, &i2);} -#define Cblacs_exit(doneflag) \ - {i1 = doneflag; \ - blacs_exit_(&i1);} - -/* Support routines: - Informational and Miscellaneous */ - -#define Cblacs_gridinfo(ictxt,nprow,npcol,myprow,mypcol) \ - {i1 = ictxt; \ - blacs_gridinfo_(&i1, nprow, npcol, myprow, mypcol);} -#define Cblacs_pnum(ictxt, prow, pcol) \ - {i1 = ictxt; i2 = prow; i3 = pcol; \ - blacs_pnum_(&i1, &i2, &i3);} -#define Cblacs_pcoord(ictxt, pnum, prow, pcol) \ - {i1 = ictxt; i2 = pnum; \ - blacs_pcoord_(&i1, &i2, prow, pcol);} -#define Cblacs_barrier(ictxt, scope) \ - {i1 = ictxt; \ - blacs_barrier_(&i1, scope);} - -/* Support routines: - Unofficial */ - -#define Csetpvmtids(ntasks, tids) \ - {i1 = ntasks; \ - setpvmtids_(&i1, tids);} -#define Cdcputime() \ - dcputime_() -#define Cdwalltime() \ - dwalltime_() -#define Cksendid(ictxt, rdest, cdest) \ - {i1 = ictxt; i2 = rdest; i3 = cdest; \ - ksendid_(&i1, &i2, &i3);} -#define Ckrecvid(ictxt, rsrc, csrc) \ - {i1 = ictxt; i2 = rsrc; i3 = csrc; \ - krecvid_(&i1, &i2, &i3);} -#define Ckbsid(ictxt, scope) \ - {i1 = ictxt; \ - kbsid_(&i1, scope);} -#define Ckbrid(ictxt, scope, rsrc, csrc) \ - {i1 = ictxt; i2 = rsrc; i3 = csrc; \ - kbrid_(&i1, scope, &i2, &i3);} - -/* Point to Point : - Integer */ - -#define Cigesd2d(ictxt, m, n, A, lda, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ - igesd2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);} -#define Cigerv2d(ictxt, m, n, A, lda, rsrc, csrc) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ - igerv2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);} -#define Citrsd2d(ictxt, uplo, diag, m, n, A, lda, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ - itrsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} -#define Citrrv2d(ictxt, uplo, diag, m, n, A, lda, rsrc, csrc) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ - itrsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} - -/* Point to Point : - Single precision real */ - -#define Csgesd2d(ictxt, m, n, A, lda, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ - sgesd2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);} -#define Csgerv2d(ictxt, m, n, A, lda, rsrc, csrc) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ - sgerv2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);} -#define Cstrsd2d(ictxt, uplo, diag, m, n, A, lda, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ - strsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} -#define Cstrrv2d(ictxt, uplo, diag, m, n, A, lda, rsrc, csrc) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ - strsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} - -/* Point to Point : - Double precision real */ - -#define Cdgesd2d(ictxt, m, n, A, lda, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ - dgesd2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);} -#define Cdgerv2d(ictxt, m, n, A, lda, rsrc, csrc) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ - dgerv2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);} -#define Cdtrsd2d(ictxt, uplo, diag, m, n, A, lda, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ - dtrsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} -#define Cdtrrv2d(ictxt, uplo, diag, m, n, A, lda, rsrc, csrc) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ - dtrsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} - -/* Point to Point : - Single precision complex */ - -#define Ccgesd2d(ictxt, m, n, A, lda, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ - cgesd2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);} -#define Ccgerv2d(ictxt, m, n, A, lda, rsrc, csrc) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ - cgerv2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);} -#define Cctrsd2d(ictxt, uplo, diag, m, n, A, lda, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ - ctrsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} -#define Cctrrv2d(ictxt, uplo, diag, m, n, A, lda, rsrc, csrc) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ - ctrsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} - -/* Point to Point : - Double precision complex */ - -#define Czgesd2d(ictxt, m, n, A, lda, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ - zgesd2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);} -#define Czgerv2d(ictxt, m, n, A, lda, rsrc, csrc) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ - zgerv2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);} -#define Cztrsd2d(ictxt, uplo, diag, m, n, A, lda, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ - ztrsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} -#define Cztrrv2d(ictxt, uplo, diag, m, n, A, lda, rsrc, csrc) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ - ztrsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} - -/* Broadcasts : - Integer */ - -#define Cigebs2d(ictxt, scope, top, m, n, A, lda) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; \ - igebs2d_(&i1, scope, top, &i2, &i3, A, &i4);} -#define Cigebr2d(ictxt, scope, top, m, n, A, lda, rsrc, csrc) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ - igebr2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);} -#define Citrbs2d(ictxt, scope, top, uplo, diag, m, n, A, lda) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; \ - itrbs2d_(&i1, scope, top, uplo, diag, &i2, &i3, A, &i4);} -#define Citrbr2d(ictxt, uplo, diag, m, n, A, lda, rsrc, csrc) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ - igebr2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} - -/* Broadcasts : - Single precision real */ - -#define Csgebs2d(ictxt, scope, top, m, n, A, lda) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; \ - sgebs2d_(&i1, scope, top, &i2, &i3, A, &i4);} -#define Csgebr2d(ictxt, scope, top, m, n, A, lda, rsrc, csrc) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ - sgebr2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);} -#define Cstrbs2d(ictxt, scope, top, uplo, diag, m, n, A, lda) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; \ - strbs2d_(&i1, scope, top, uplo, diag, &i2, &i3, A, &i4);} -#define Cstrbr2d(ictxt, uplo, diag, m, n, A, lda, rsrc, csrc) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ - sgebr2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} - -/* Broadcasts : - Double precision real */ - -#define Cdgebs2d(ictxt, scope, top, m, n, A, lda) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; \ - dgebs2d_(&i1, scope, top, &i2, &i3, A, &i4);} -#define Cdgebr2d(ictxt, scope, top, m, n, A, lda, rsrc, csrc) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ - dgebr2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);} -#define Cdtrbs2d(ictxt, scope, top, uplo, diag, m, n, A, lda) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; \ - dtrbs2d_(&i1, scope, top, uplo, diag, &i2, &i3, A, &i4);} -#define Cdtrbr2d(ictxt, uplo, diag, m, n, A, lda, rsrc, csrc) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ - dgebr2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} - -/* Broadcasts : - Single precision complex */ - -#define Ccgebs2d(ictxt, scope, top, m, n, A, lda) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; \ - cgebs2d_(&i1, scope, top, &i2, &i3, A, &i4);} -#define Ccgebr2d(ictxt, scope, top, m, n, A, lda, rsrc, csrc) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ - cgebr2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);} -#define Cctrbs2d(ictxt, scope, top, uplo, diag, m, n, A, lda) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; \ - ctrbs2d_(&i1, scope, top, uplo, diag, &i2, &i3, A, &i4);} -#define Cctrbr2d(ictxt, uplo, diag, m, n, A, lda, rsrc, csrc) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ - cgebr2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} - -/* Broadcasts : - Double precision complex */ - -#define Czgebs2d(ictxt, scope, top, m, n, A, lda) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; \ - zgebs2d_(&i1, scope, top, &i2, &i3, A, &i4);} -#define Czgebr2d(ictxt, scope, top, m, n, A, lda, rsrc, csrc) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ - zgebr2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);} -#define Cztrbs2d(ictxt, scope, top, uplo, diag, m, n, A, lda) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; \ - ztrbs2d_(&i1, scope, top, uplo, diag, &i2, &i3, A, &i4);} -#define Cztrbr2d(ictxt, uplo, diag, m, n, A, lda, rsrc, csrc) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ - zgebr2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} - -/* Combines: - Integer */ - -#define Cigsum2d(ictxt, scope, top, m, n, A, lda, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ - igsum2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);} -#define Cigamx2d(ictxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \ - igamx2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);} -#define Cigamn2d(ictxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \ - igamn2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);} - -/* Combines: - Single precision real */ - -#define Csgsum2d(ictxt, scope, top, m, n, A, lda, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ - sgsum2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);} -#define Csgamx2d(ictxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \ - sgamx2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);} -#define Csgamn2d(ictxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \ - sgamn2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);} - -/* Combines: - Double precision real */ - -#define Cdgsum2d(ictxt, scope, top, m, n, A, lda, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ - dgsum2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);} -#define Cdgamx2d(ictxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \ - dgamx2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);} -#define Cdgamn2d(ictxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \ - dgamn2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);} - -/* Combines: - Single precision complex */ - -#define Ccgsum2d(ictxt, scope, top, m, n, A, lda, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ - cgsum2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);} -#define Ccgamx2d(ictxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \ - cgamx2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);} -#define Ccgamn2d(ictxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \ - cgamn2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);} - -/* Combines: - Double precision complex */ - -#define Czgsum2d(ictxt, scope, top, m, n, A, lda, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ - zgsum2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);} -#define Czgamx2d(ictxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \ - zgamx2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);} -#define Czgamn2d(ictxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \ - {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \ - zgamn2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);} - - - diff --git a/src/internals/psblas.h b/src/internals/psblas.h deleted file mode 100644 index 72313d6c4..000000000 --- a/src/internals/psblas.h +++ /dev/null @@ -1,316 +0,0 @@ -/* - * Parallel Sparse BLAS v2.0 - * (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata - * Alfredo Buttari University of Rome Tor Vergata - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions - * are met: - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions, and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * 3. The name of the PSBLAS group or the names of its contributors may - * not be used to endorse or promote products derived from this - * software without specific written permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS - * ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED - * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR - * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS - * BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR - * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF - * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS - * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN - * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) - * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - * POSSIBILITY OF SUCH DAMAGE. - * - */ - -/* -* This file includes the standard C libraries, as well as system -* dependent include files. All PSBLAS routines include this file. -*/ -#include - -#ifndef PSBLASH -#define PSBLASH -/* -* ======================================================================== -* Machine Specific PBLAS macros -* ======================================================================== -*/ -/* This is a debugging option. - #define PS_CONTROL_LEVEL */ - -#define _HAL_ 0 -#define _T3D_ 1 - -#ifdef T3D -#define _MACH_ _T3D_ -#endif - -#ifndef _MACH_ -#define _MACH_ _HAL_ -#endif - -/* -* ======================================================================== -* Include files -* ======================================================================== -*/ -#include -#include -#include - -#if( _MACH_ == _T3D_ ) -#include -#endif - -#ifdef USE_FBLACS -#ifndef CTOF_BLACS -#include "ctof_blacs.h" -#endif -#endif - - - -/* -* ======================================================================== -* FORTRAN <-> C interface -* ======================================================================== -* -* These macros define how the PBLAS will be called. _F2C_ADD_ assumes -* that they will be called by FORTRAN, which expects C routines to have -* an underscore postfixed to the name (Suns, and Intel machines expect -* this). _F2C_NOCHANGE indicates that FORTRAN will be calling, and that -* it expects the name called by FORTRAN to be identical to that compiled -* by the C (RS6K's do this). _F2C_UPCASE says it expects C routines -* called by FORTRAN to be in all upcase (CRAY wants this). -*/ - -#define _F2C_ADD_ 0 -#define _F2C_NOCHANGE 1 -#define _F2C_UPCASE 2 - -#ifdef UpCase -#define _F2C_CALL_ _F2C_UPCASE -#endif - -#ifdef NoChange -#define _F2C_CALL_ _F2C_NOCHANGE -#endif - -#ifdef Add_ -#define _F2C_CALL_ _F2C_ADD_ -#endif - -#ifndef _F2C_CALL_ -#define _F2C_CALL_ _F2C_ADD_ -#endif - -/* -* ======================================================================== -* TYPE DEFINITIONS AND CONVERSION UTILITIES -* ======================================================================== -*/ - -typedef struct { float re, im; } complex; -typedef struct { double re, im; } complex16; - -#if( _MACH_ == _T3D_ ) - /* Type of character argument in a FORTRAN call */ -#define F_CHAR _fcd - /* Character conversion utilities */ -#define F2C_CHAR(a) ( _fcdtocp( (a) ) ) -#define C2F_CHAR(a) ( _cptofcd( (a), 1 ) ) - /* Type of FORTRAN functions */ -#define F_VOID_FCT void fortran /* Subroutine */ -#define F_INTG_FCT int fortran /* INTEGER function */ -#define F_DBLE_FCT double fortran /* DOUBLE PRECISION function */ - -#else - /* Type of character argument in a FORTRAN call */ -typedef char * F_CHAR; - /* Character conversion utilities */ -#define F2C_CHAR(a) (a) -#define C2F_CHAR(a) (a) - /* Type of FORTRAN functions */ -#define F_VOID_FCT void /* Subroutine */ -#define F_INTG_FCT int /* INTEGER function */ -#define F_DBLE_FCT double /* DOUBLE PRECISION function */ - -#endif - -/* -* ====================================================================== -* FUNCTIONS PROTOTYPES -* ====================================================================== -*/ -void DVSct(int n, int k,int idx[],int flag, double X[], int lx, - double beta, double Y[], int ly); -void DVGth(int n, int k,int idx[],int flag, double X[], int lx,double Y[], int ly); -void IVSct(int n, int k,int idx[],int flag, int X[], int lx, - int beta, int Y[], int ly); -void IVGth(int n, int k,int idx[],int flag, int X[], int lx,int Y[], int ly); - -void PSI_dSwapData(int iflag, int n, double beta, double Y[], int ly, - int desc_data[], int desc_halo[], - double *work, int *lwork, int *ierror); - -void PSI_dSwapTran(int flag, int n, double beta, double Y[], int ly, - int desc_data[], int desc_halo[], - double *work, int *lwork, int *ierror); - -void PSI_zSwapData(int n, double Y[], int ly, int desc_data[], int desc_halo[], - double *work, int *lwork, int *ierror); - -void PSI_zSwapOverlap(double Y[], double Sum_Ovrlap[], int desc_data[], - int desc_ovrlap[], double work[], int *lwork, int *ierror); -void PSI_iSwapData(int iflag, int n, int beta, int Y[], int ly, - int desc_data[], int desc_halo[], - int *work, int *lwork, int *ierror); - -void PSI_iSwapTran(int flag, int n, int beta, int Y[], int ly, - int desc_data[], int desc_halo[], - int *work, int *lwork, int *ierror); - -/* -* ======================================================================== -* #DEFINE MACRO CONSTANTS -* ======================================================================== -*/ -/* MACRO max */ -#define max(x,y) ((x)>(y)?(x):(y)) - -/*MACRO for ovrlap update*/ -#define NOHALO_ 0 -#define HALO_ 4 -#define NONE_ 0 -#define SUM_ 1 -#define AVG_ 2 -#define SQUARE_ROOT_ 3 - -/* Bit fields to control swapdata/ovrlap behaviour. - BEWARE: check consistency with tools_const.f. - Should it be automated? */ -#define SWAP_SEND 1 -#define SWAP_RECV 2 -#define SWAP_SYNC 4 -#define SWAP_MPI 8 - - -/* Macro for MATRIX_DATA array */ -#define DEC_TYPE_ 0 /* The type of decomposition of global - matrix A. */ -#define M_ 1 /* Number of equations */ -#define N_ 2 /* Number of variables */ -#define N_ROW_ 3 /* The number of row of local matrix. */ -#define N_COL_ 4 /* The number of columns of local - matrix. */ -#define CTXT_ 5 /* The BLACS context handle, indicating - the global context of the operation - on the matrix. - The context itself is global. */ -#define LOC_TO_GLOB_ 6 /* The pointer to the array - loc_to_glob */ -#define MPI_C_ 8 /* The MPI Fortran handle */ -/* values for DEC_TYPE_ */ -#define DESC_ASB 3099 -#define DESC_BLD (DESC_ASB+1) - -/* Macro for HALO array */ -#define PROC_ID_ 0 /* The identifier of domain. */ -#define N_ELEM_RECV_ 1 /* The number of elements to receive*/ -#define ELEM_RECV_ 2 /* The first index of local elements */ -#define N_ELEM_SEND_ 2 /* The number of elements to send */ -#define ELEM_SEND_ 3 /* The first index of local elements */ - -/* Macro for OVERLAP array */ -#define N_OVRLP_ELEM_ 1 /* The number of overlap elements to recv/send */ -#define OVRLP_ELEM_TO_ 2 /* The first index of local elements */ - -/* Macro for OVR_ELEM_D array */ -#define OVRLP_ELEM_ 0 -#define N_DOM_OVR_ 1 - -#define BROADCAST "B" /* Blacs operation definitions */ -#define COMBINE "C" - -#define ALL "A" /* Scope definitions */ -#define COLUMN "C" -#define ROW "R" - -#define TOPDEF " " /* Default BLACS topology, PB-BLAS routines */ -#define CTOPDEF ' ' -#define TOPGET "!" - -#define YES "Y" -#define NO "N" - -#define MULLENFAC 2 - -#define ONE 1.0 -#define ZERO 0.0 - -/* Integer values for error checking */ -#define no_err 0 -#define act_ret 0 -#define act_abort 1 - - -/* -* ======================================================================== -* PREPROCESSOR MACRO FUNCTIONS USED FOR OPTIMIZATION & CONVENIENCE -* ======================================================================== -*/ - -#define ABS(a) ((a > 0) ? (a) : (-a)) - -#define MIN(a,b) ((a < b) ? (a) : (b)) - -#define MAX(a,b) ((a > b) ? (a) : (b)) - -#define CEIL(a,b) ( (a+b-1) / (b) ) - -#define Mlowcase(C) ( ((C) > 64 && (C) < 91) ? (C) | 32 : (C) ) - -#define Mupcase(C) ( ((C) > 96 && (C) < 123) ? (C) & 0xDF : (C) ) - -#define INDXG2L( iglob, nb, iproc, isrcproc, nprocs )\ - ( (nb) * ( ( (iglob)-1) / ( (nb) * (nprocs) ) ) +\ - ( ( (iglob) - 1 ) % (nb) ) + 1 ) - -#define INDXL2G( iloc, nb, iproc, isrcproc, nprocs )\ - ( (nprocs) * (nb) * ( ( (iloc) - 1 ) / (nb) ) +\ - ( ( (iloc) - 1 ) % (nb) ) +\ - ( ( (nprocs) + (iproc) - (isrcproc) ) % (nprocs) ) * (nb) + 1 ) - -#define INDXG2P( iglob, nb, iproc, isrcproc, nprocs ) \ - ( ( (isrcproc) + ( (iglob) - 1 ) / (nb) ) % (nprocs) ) - -#define MYROC0( nblocks, n, nb, nprocs )\ - ( ( (nblocks) % (nprocs) ) ? ( ( (nblocks) / (nprocs) ) * (nb) + (nb) )\ - : ( ( (nblocks) / (nprocs) )* (nb) + ( (n) % (nb) ) ) ) - -#if( _F2C_CALL_ == _F2C_ADD_ ) -/* -* These defines set up the naming scheme required to have a FORTRAN -* routine call a C routine (which is what the PBLAS are written in). -* No redefinition necessary to have following FORTRAN to C interface: -* FORTRAN CALL C DECLARATION -* call pdgemm(...) void pdgemm_(...) -* -* This is the default. -*/ -#define pbchkvectf pbchkvectf_ -#define fcpsb_errcomm fcpsb_errcomm_ -#define fcpsb_erractionsave fcpsb_erractionsave_ -#define fcpsb_erractionrestore fcpsb_erractionrestore_ -#define fcpsb_perror fcpsb_perror_ -#define fcpsb_serror fcpsb_serror_ -#define fcpsb_errpush fcpsb_errpush_ -#endif - diff --git a/src/internals/psi_crea_index.f90 b/src/internals/psi_crea_index.f90 index 9b50befd8..6f95a88fd 100644 --- a/src/internals/psi_crea_index.f90 +++ b/src/internals/psi_crea_index.f90 @@ -28,7 +28,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info) +subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info) use psb_realloc_mod use psb_descriptor_type @@ -37,7 +37,7 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info) implicit none type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info + integer, intent(out) :: info,nxch,nsnd,nrcv integer, intent(in) :: index_in(:) integer, pointer :: index_out(:) logical :: glob_idx @@ -50,13 +50,6 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info) logical,parameter :: debug=.false. character(len=20) :: name - interface - subroutine psi_compute_size(desc_data,& - & index_in, dl_lda, info) - integer :: info, dl_lda - integer :: desc_data(:), index_in(:) - end subroutine psi_compute_size - end interface interface subroutine psi_sort_dl(dep_list,l_dep_list,np,info) @@ -73,12 +66,12 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info) interface subroutine psi_desc_index(desc_data,index_in,dep_list,& - & length_dl,loc_to_glob,glob_to_loc,desc_index,& + & length_dl,nsnd,nrcv,loc_to_glob,glob_to_loc,desc_index,& & isglob_in,info) integer :: desc_data(:),index_in(:),dep_list(:) integer :: loc_to_glob(:),glob_to_loc(:) integer,pointer :: desc_index(:) - integer :: length_dl, info + integer :: length_dl,nsnd,nrcv, info logical :: isglob_in end subroutine psi_desc_index end interface @@ -96,7 +89,6 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info) endif ! allocate dependency list - ! call psi_compute_size(desc_a%matrix_data, index_in, dl_lda, info) ! This should be computed more efficiently to save space when ! the number of processors becomes very high dl_lda=np+1 @@ -119,10 +111,10 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info) goto 9999 end if - if (debug) write(*,*) 'crea_index: from extract_dep_list',& + if (debug) write(0,*) 'crea_index: from extract_dep_list',& & me,length_dl(0),index_in(1), ':',dep_list(:length_dl(me),me) ! ...now process root contains dependence list of all processes... - if (debug) write(*,*) 'crea_halo: root sorting dep list' + if (debug) write(0,*) 'crea_index: root sorting dep list' ! ....i must order communication in in halo call psi_dl_check(dep_list,max(1,dl_lda),np,length_dl) @@ -138,9 +130,11 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info) if(debug) write(0,*)'in psi_crea_index calling psi_desc_index',& & size(index_out) call psi_desc_index(desc_a%matrix_data,index_in,dep_list(1:,me),& - & length_dl(me),desc_a%loc_to_glob,desc_a%glob_to_loc,& + & length_dl(me),nsnd,nrcv,desc_a%loc_to_glob,desc_a%glob_to_loc,& & index_out,glob_idx,info) - + if(debug) write(0,*)'out of psi_desc_index',& + & size(index_out) + nxch = length_dl(me) if(info /= 0) then call psb_errpush(4010,name,a_err='psi_desc_index') goto 9999 diff --git a/src/internals/psi_crea_ovr_elem.f90 b/src/internals/psi_crea_ovr_elem.f90 index 2988779f2..900544285 100644 --- a/src/internals/psi_crea_ovr_elem.f90 +++ b/src/internals/psi_crea_ovr_elem.f90 @@ -45,58 +45,128 @@ subroutine psi_crea_ovr_elem(desc_overlap,ovr_elem) integer :: psi_exist_ovr_elem,dim external :: psi_exist_ovr_elem - logical, parameter :: usetree=.true. - + integer :: nel, ip, ix, iel, insize + integer, allocatable :: telem(:,:) + + logical, parameter :: usetree=.false. + if (associated(ovr_elem)) then dim_ovr_elem=size(ovr_elem) else dim_ovr_elem = 0 endif - i=1 - pnt_new_elem=1 - if (usetree) call initpairsearchtree(pairtree,info) - do while (desc_overlap(i).ne.-1) - ! ...loop over all procs of desc_overlap list.... - - i=i+1 - do j=1,desc_overlap(i) - ! ....loop over all overlap indices referred to act proc..... - if (usetree) then + + + if (usetree) then + + ! + ! While running through the column indices exchanged with other procs + ! we have to record them in overlap_elem. We do this by maintaining + ! an AVL balanced search tree: at each point counter_e is the next + ! free index element. The search routine for gidx will return + ! glx if gidx was already assigned a local index (glx dim_ovr_elem) then + dim_ovr_elem=max(((3*dim_ovr_elem)/2+2),pnt_new_elem+100) + call psb_realloc(dim_ovr_elem,ovr_elem,info) + if (info /= 0) then + write(0,*) 'Error in CREA_OVR_ELEM' + endif endif + ovr_elem(pnt_new_elem)=desc_overlap(i+j) + ovr_elem(pnt_new_elem+1)=2 + pnt_new_elem=pnt_new_elem+2 + + else + ! ....this point already exist in ovr_elem list + ! its position is ret............................ + ovr_elem(ret+1)=ovr_elem(ret+1)+1 endif - else - ! ....this point already exist in ovr_elem list - ! its position is ret............................ - ovr_elem(ret+1)=ovr_elem(ret+1)+1 - endif + enddo + i=i+2*desc_overlap(i)+2 enddo - i=i+2*desc_overlap(i)+2 - enddo - ! ...add -1 at the end of output list...... - ovr_elem(pnt_new_elem)=-1 - if (usetree) call freepairsearchtree(pairtree) + ! Add -1 at the end of output list. + ! And fix the size to the minimum necessary. + dim_ovr_elem=pnt_new_elem + call psb_realloc(dim_ovr_elem,ovr_elem,info) + if (info /= 0) then + write(0,*) 'Error in CREA_OVR_ELEM' + endif + ovr_elem(pnt_new_elem)=-1 + call freepairsearchtree(pairtree) + else + + insize = size(desc_overlap) + insize = max(1,(insize+1)/2) + allocate(telem(insize,2),stat=info) + if (info /= 0) then + write(0,*) 'Error in CREA_OVR_ELEM' + endif + i = 1 + nel = 0 + do while (desc_overlap(i).ne.-1) + ! ...loop over all procs of desc_overlap list.... + i=i+1 + do j=1,desc_overlap(i) + nel = nel + 1 + telem(nel,1) = desc_overlap(i+j) + enddo + i=i+2*desc_overlap(i)+2 + enddo + if (nel > 0) then + call imsr(nel,telem(:,1)) + iel = telem(1,1) + telem(1,2) = 2 + ix = 1 + ip = 2 + do + if (ip > nel) exit + if (telem(ip,1) == iel) then + telem(ix,2) = telem(ix,2) + 1 + else + ix = ix + 1 + telem(ix,1) = telem(ip,1) + iel = telem(ip,1) + telem(ix,2) = 2 + end if + ip = ip + 1 + end do + else + ix = 0 + end if + dim_ovr_elem=2*ix+1 + call psb_realloc(dim_ovr_elem,ovr_elem,info) + iel = 1 + do i=1, ix + ovr_elem(iel) = telem(i,1) + ovr_elem(iel+1) = telem(i,2) + iel = iel + 2 + end do + ovr_elem(iel) = -1 + deallocate(telem) + endif end subroutine psi_crea_ovr_elem diff --git a/src/internals/psi_desc_index.f90 b/src/internals/psi_desc_index.f90 index 4446179ba..8c65b9587 100644 --- a/src/internals/psi_desc_index.f90 +++ b/src/internals/psi_desc_index.f90 @@ -29,7 +29,7 @@ !!$ !!$ subroutine psi_desc_index(desc_data,index_in,dep_list,& - & length_dl,loc_to_glob,glob_to_loc,desc_index,& + & length_dl,nsnd,nrcv,loc_to_glob,glob_to_loc,desc_index,& & isglob_in,info) use psb_realloc_mod @@ -39,23 +39,22 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,& use psb_penv_mod implicit none - !c ...array parameters..... + ! ...array parameters..... integer :: desc_data(:),index_in(:),dep_list(:) integer :: loc_to_glob(:),glob_to_loc(:) integer,pointer :: desc_index(:) - integer :: length_dl, info + integer :: length_dl, nsnd,nrcv,info logical :: isglob_in - !c ....local scalars... + ! ....local scalars... integer :: j,me,np,i,proc - !c ...parameters... + ! ...parameters... integer :: ictxt integer :: no_comm,err parameter (no_comm=-1) - !c ...local arrays.. - integer,pointer :: brvindx(:),rvsz(:),& - & bsdindx(:),sdsz(:), sndbuf(:), rcvbuf(:) + ! ...local arrays.. + integer,pointer :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:), sndbuf(:), rcvbuf(:) - integer :: ihinsz,ntot,k,err_act,& + integer :: ihinsz,ntot,k,err_act, l_di, & & idxr, idxs, iszs, iszr, nesd, nerv, icomm logical,parameter :: debug=.false., usempi=.true. @@ -65,9 +64,8 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,& name='psi_desc_index' call psb_erractionsave(err_act) - !c if mode == 1 then we can use glob_to_loc array - !c else we can't utilize it ictxt=desc_data(psb_ctxt_) + icomm=desc_data(psb_mpi_c_) call psb_info(ictxt,me,np) if (np == -1) then info = 2010 @@ -80,13 +78,12 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,& call psb_barrier(ictxt) endif - call psb_get_mpicomm(ictxt,icomm) - !c - !c first, find out the total sizes to be exchanged. - !c note: things marked here as sndbuf/rcvbuf (for mpi) corresponds to things - !c to be received/sent (in the final psblas descriptor). - !c be careful of the inversion - !c + ! + ! first, find out the total sizes to be exchanged. + ! note: things marked here as sndbuf/rcvbuf (for mpi) corresponds to things + ! to be received/sent (in the final psblas descriptor). + ! be careful of the inversion + ! allocate(sdsz(np),rvsz(np),bsdindx(np),brvindx(np),stat=info) if(info /= 0) then info=4000 @@ -126,6 +123,9 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,& end do iszs = sum(sdsz) iszr = sum(rvsz) + nsnd = iszr + nrcv = iszs + if ((iszs /= idxs).or.(iszr /= idxr)) then write(0,*) 'strange results???', iszs,idxs,iszr,idxr end if @@ -134,11 +134,14 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,& call psb_barrier(ictxt) endif - ntot = (3*(max(count(sdsz>0),count(rvsz>0)))+ iszs + iszr) + 1 - if (size(desc_index) < ntot) then - !c$$$ write(0,*) 'potential error on desc_index :', - !c$$$ + length_dh, size(desc_index),ntot - write(0,*) 'calling irealloc psi_desc_index ',ntot + ntot = (3*(count((sdsz>0).or.(rvsz>0)))+ iszs + iszr) + 1 + + if (associated(desc_index)) then + l_di = size(desc_index) + else + l_di = 0 + endif + if (l_di < ntot) then call psb_realloc(ntot,desc_index,info) endif if (info /= 0) then @@ -167,9 +170,9 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,& proc = index_in(i) i = i + 1 nerv = index_in(i) - ! c - ! c note that here bsdinx is zero-based, hence the following loop - ! c + ! + ! note that here bsdinx is zero-based, hence the following loop + ! if (isglob_in) then do j=1, nerv sndbuf(bsdindx(proc+1)+j) = (index_in(i+j)) @@ -187,9 +190,9 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,& write(0,*) me,' prepared send buffer ' call psb_barrier(ictxt) endif - !c - !c now have to regenerate bsdindx - !c + ! + ! now have to regenerate bsdindx + ! idxs = 0 idxr = 0 do i=1, length_dl @@ -207,10 +210,10 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,& goto 9999 end if - !c - !c at this point we can finally build the output desc_index. beware - !c of snd/rcv inversion. - !c + ! + ! at this point we can finally build the output desc_index. beware + ! of snd/rcv inversion. + ! i = 1 do k = 1, length_dl proc = dep_list(k) diff --git a/src/internals/psi_dswapdata.f90 b/src/internals/psi_dswapdata.f90 index be1f0f54b..0903d979f 100644 --- a/src/internals/psi_dswapdata.f90 +++ b/src/internals/psi_dswapdata.f90 @@ -33,8 +33,8 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) use psb_error_mod use psb_descriptor_type use psb_penv_mod - use mpi use psi_gthsct_mod + use mpi implicit none integer, intent(in) :: flag, n @@ -47,13 +47,17 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) ! locals integer :: ictxt, np, me, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& - & idxs, idxr, iret, err_act, totxch, ixrec, i, & - & idx_pt, snd_pt, rcv_pt + & idxs, idxr, iret, err_act, totxch, ixrec, i, idx_pt,& + & snd_pt, rcv_pt, pnti integer :: krecvid, ksendid - integer, pointer, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, ptp, rvhd, d_idx + integer, allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer, pointer :: d_idx(:) integer :: int_err(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv, all + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + real(kind(1.d0)), pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name @@ -68,96 +72,130 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) call psb_errpush(info,name) goto 9999 endif - - call psb_get_mpicomm(ictxt,icomm) - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), prcid(0:np-1),& - & ptp(0:np-1), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if (.not.psb_is_asb_dec(desc_a%matrix_data(psb_dec_type_))) then + info = 1122 + call psb_errpush(info,name) goto 9999 - end if + endif + + + icomm = desc_a%matrix_data(psb_mpi_c_) - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv if(present(data)) then if(data == psb_comm_halo_) then d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) + else if(data == psb_comm_ovr_) then d_idx => desc_a%ovrlap_index + totxch = desc_a%matrix_data(psb_tovr_xch_) + idxr = desc_a%matrix_data(psb_tovr_rcv_) + idxs = desc_a%matrix_data(psb_tovr_snd_) else d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) end if else d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) end if + idxr = idxr * n + idxs = idxs * n - idxs = 1 - idxr = 1 - totxch = 0 - point_to_proc = 1 - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 - ! prepare info for communications - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - if(proc_to_comm /= me) totxch = totxch+1 - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + ! prepare info for communications - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - ptp(proc_to_comm) = point_to_proc - brvidx(proc_to_comm) = idxr - rvsz(proc_to_comm) = n*nerv - idxr = idxr+rvsz(proc_to_comm) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - bsdidx(proc_to_comm) = idxs - sdsz(proc_to_comm) = n*nesd - idxs = idxs+sdsz(proc_to_comm) + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do if((idxr+idxs) < size(work)) then sndbuf => work(1:idxs) rcvbuf => work(idxs+1:idxs+idxr) - all=.false. + albf=.false. else allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if - all=.true. + albf=.true. end if - ! Case SWAP_MPI - if(swap_mpi) then + if (do_send) then - ! gather elements into sendbuffer for swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) + end if - call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + + ! Case SWAP_MPI + if (swap_mpi) then ! swap elements using mpi_alltoallv call mpi_alltoallv(sndbuf,sdsz,bsdidx,& @@ -170,268 +208,186 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - ! scatter elements from receivebuffer after swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - else if (swap_sync) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm < me) then - ! First I send - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) - ! Then I receive - rcv_pt = brvidx(proc_to_comm) - call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) else if (proc_to_comm > me) then - ! First I receive - rcv_pt = brvidx(proc_to_comm) - call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) - ! Then I send - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) - else if (proc_to_comm == me) then - ! I send to myself - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) end if + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - else - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do else if (swap_send .and. swap_recv) then - ! First I post all the non blocking receives - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - p2ptag = krecvid(ictxt,proc_to_comm,me) - rcv_pt = brvidx(proc_to_comm) - call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),& - & mpi_double_precision,prcid(proc_to_comm),& - & p2ptag, icomm,rvhd(proc_to_comm),iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + ! First I post all the non blocking receives + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = krecvid(ictxt,proc_to_comm,me) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& + & mpi_double_precision,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 end do + ! Then I post all the blocking sends - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if (usersend) call mpi_barrier(icomm,info) - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) - if(proc_to_comm /= me) then - p2ptag=ksendid(ictxt,proc_to_comm,me) - call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),& - & mpi_double_precision,prcid(proc_to_comm),& + p2ptag=ksendid(ictxt,proc_to_comm,me) + + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),n*nesd,& + & mpi_double_precision,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),n*nesd,& + & mpi_double_precision,prcid(i),& & p2ptag,icomm,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - if(.false.) then - do i=1, totxch - call mpi_waitany(np,rvhd,ixrec,p2pstat,iret) + + + pnti = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = krecvid(ictxt,proc_to_comm,me) + + if (proc_to_comm /= me) then + call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) goto 9999 end if + end if + pnti = pnti + nerv + nesd + 3 + end do + - if (ixrec /= mpi_undefined) then - ixrec=ixrec-1 ! mpi_waitany returns an 1 to np index - point_to_proc = ptp(ixrec) - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - else - int_err(1) = ixrec - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm == me) then - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - else + else if (swap_send) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - else - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - end if + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + end do - end if + else if (swap_recv) then - else if (swap_send) then + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + end if - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - else if (swap_recv) then + if (do_recv) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - rcv_pt = brvidx(proc_to_comm) - call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - else - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 end do end if - deallocate(sdsz,rvsz,bsdidx,& - & brvidx,rvhd,prcid,& - & ptp,stat=info) - if(all) deallocate(sndbuf,rcvbuf,stat=info) + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) if(info /= 0) then call psb_errpush(4000,name) goto 9999 @@ -500,18 +456,22 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) integer :: ictxt, np, me, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & idxs, idxr, iret, err_act, totxch, ixrec, i, & - & idx_pt, snd_pt, rcv_pt, n + & idx_pt, snd_pt, rcv_pt, n, pnti - integer, pointer, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, ptp, rvhd, d_idx + integer, allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer, pointer :: d_idx(:) integer :: krecvid, ksendid integer :: int_err(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv,all + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + real(kind(1.d0)), pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name info = 0 - name='psi_dswap_datav' + name='psi_swap_datav' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) @@ -522,97 +482,132 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) goto 9999 endif - call psb_get_mpicomm(ictxt,icomm) + if (.not.psb_is_asb_dec(desc_a%matrix_data(psb_dec_type_))) then + info = 1122 + call psb_errpush(info,name) + goto 9999 + endif + icomm = desc_a%matrix_data(psb_mpi_c_) + n=1 - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), prcid(0:np-1),& - & ptp(0:np-1), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv if(present(data)) then if(data == psb_comm_halo_) then d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) + else if(data == psb_comm_ovr_) then d_idx => desc_a%ovrlap_index + totxch = desc_a%matrix_data(psb_tovr_xch_) + idxr = desc_a%matrix_data(psb_tovr_rcv_) + idxs = desc_a%matrix_data(psb_tovr_snd_) else d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) end if else d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) end if - idxs = 1 - idxr = 1 - totxch = 0 - point_to_proc = 1 - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - n=1 - ! prepare info for communications - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - if(proc_to_comm /= me) totxch = totxch+1 - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + idxr = idxr * n + idxs = idxs * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - ptp(proc_to_comm) = point_to_proc + ! prepare info for communications - brvidx(proc_to_comm) = idxr - rvsz(proc_to_comm) = n*nerv - idxr = idxr+rvsz(proc_to_comm) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + end if - bsdidx(proc_to_comm) = idxs - sdsz(proc_to_comm) = n*nesd - idxs = idxs+sdsz(proc_to_comm) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do if((idxr+idxs) < size(work)) then sndbuf => work(1:idxs) rcvbuf => work(idxs+1:idxs+idxr) - all=.false. + albf=.false. else allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if - all=.true. + albf=.true. end if - ! Case SWAP_MPI - if(swap_mpi) then - ! gather elements into sendbuffer for swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if (do_send) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& & y,sndbuf(snd_pt:snd_pt+nesd-1)) - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 end do + end if + + ! Case SWAP_MPI + if (swap_mpi) then + ! swap elements using mpi_alltoallv call mpi_alltoallv(sndbuf,sdsz,bsdidx,& & mpi_double_precision,rcvbuf,rvsz,& @@ -624,268 +619,170 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) goto 9999 end if - ! scatter elements from receivebuffer after swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - else if (swap_sync) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm < me) then - ! First I send - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - ! Then I receive - rcv_pt = brvidx(proc_to_comm) call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) else if (proc_to_comm > me) then - ! First I receive - rcv_pt = brvidx(proc_to_comm) call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - ! Then I send - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - ! I send to myself - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 end do - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - else - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do else if (swap_send .and. swap_recv) then - ! First I post all the non blocking receives - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - p2ptag = krecvid(ictxt,proc_to_comm,me) - rcv_pt = brvidx(proc_to_comm) - call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),& - & mpi_double_precision,prcid(proc_to_comm),& - & p2ptag, icomm,rvhd(proc_to_comm),iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = krecvid(ictxt,proc_to_comm,me) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + call mpi_irecv(rcvbuf(rcv_pt),nerv,& + & mpi_double_precision,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 end do + ! Then I post all the blocking sends - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) + if (usersend) call mpi_barrier(icomm,info) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) - if(proc_to_comm /= me) then - p2ptag=ksendid(ictxt,proc_to_comm,me) - call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),& - & mpi_double_precision,prcid(proc_to_comm),& + p2ptag=ksendid(ictxt,proc_to_comm,me) + + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),nesd,& + & mpi_double_precision,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),nesd,& + & mpi_double_precision,prcid(i),& & p2ptag,icomm,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 end do - if(.false.) then - do i=1, totxch - call mpi_waitany(np,rvhd,ixrec,p2pstat,iret) + pnti = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = krecvid(ictxt,proc_to_comm,me) + + if (proc_to_comm /= me) then + call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) goto 9999 end if - if (ixrec /= mpi_undefined) then - ixrec=ixrec-1 ! mpi_waitany returns an 1 to np index - point_to_proc = ptp(ixrec) - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - else - int_err(1) = ixrec - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm == me) then - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - else - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - else - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - end if + end if + pnti = pnti + nerv + nesd + 3 + end do else if (swap_send) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 end do else if (swap_recv) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if - if(proc_to_comm /= me) then - rcv_pt = brvidx(proc_to_comm) - call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - else - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 end do end if - deallocate(sdsz,rvsz,bsdidx,& - & brvidx,rvhd,prcid,& - & ptp,stat=info) - if(all) deallocate(sndbuf,rcvbuf,stat=info) + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) if(info /= 0) then call psb_errpush(4000,name) goto 9999 diff --git a/src/internals/psi_dswaptran.f90 b/src/internals/psi_dswaptran.f90 index d6569e4f4..9e5c1a90b 100644 --- a/src/internals/psi_dswaptran.f90 +++ b/src/internals/psi_dswaptran.f90 @@ -48,18 +48,21 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) integer :: ictxt, np, me, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & idxs, idxr, iret, err_act, totxch, ixrec, i, idx_pt,& - & snd_pt, rcv_pt - - integer, pointer, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, ptp, rvhd, d_idx - integer :: int_err(5) + & snd_pt, rcv_pt, pnti integer :: krecvid, ksendid - logical :: swap_mpi, swap_sync, swap_send, swap_recv, all + integer, allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer, pointer :: d_idx(:) + integer :: int_err(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + real(kind(1.d0)), pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name info = 0 - name='psi_dswaptranm' + name='psi_swap_tran' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) @@ -70,99 +73,139 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) goto 9999 endif - call psb_get_mpicomm(ictxt,icomm) - - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), prcid(0:np-1),& - & ptp(0:np-1), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if (.not.psb_is_asb_dec(desc_a%matrix_data(psb_dec_type_))) then + info = 1122 + call psb_errpush(info,name) goto 9999 - end if + endif + + + icomm = desc_a%matrix_data(psb_mpi_c_) swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv if(present(data)) then if(data == psb_comm_halo_) then d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) + else if(data == psb_comm_ovr_) then d_idx => desc_a%ovrlap_index + totxch = desc_a%matrix_data(psb_tovr_xch_) + idxr = desc_a%matrix_data(psb_tovr_rcv_) + idxs = desc_a%matrix_data(psb_tovr_snd_) else d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) end if else d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) + end if + idxr = idxr * n + idxs = idxs * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if end if - idxs = 1 - idxr = 1 - totxch = 0 - point_to_proc = 1 - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - ! prepare info for communications - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - if(proc_to_comm /= me) totxch = totxch+1 - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - ptp(proc_to_comm) = point_to_proc - - brvidx(proc_to_comm) = idxr - rvsz(proc_to_comm) = n*nerv - idxr = idxr+rvsz(proc_to_comm) - - bsdidx(proc_to_comm) = idxs - sdsz(proc_to_comm) = n*nesd - idxs = idxs+sdsz(proc_to_comm) - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do if((idxr+idxs) < size(work)) then sndbuf => work(1:idxs) rcvbuf => work(idxs+1:idxs+idxr) - all=.false. + albf=.false. else allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if - all=.true. + albf=.true. end if - ! Case SWAP_MPI - if(swap_mpi) then - - ! gather elements into sendbuffer for swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if (do_send) then - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) + & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 end do + end if + + + + ! Case SWAP_MPI + if (swap_mpi) then + ! swap elements using mpi_alltoallv call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & mpi_double_precision,sndbuf,sdsz,& - & bsdidx,mpi_double_precision,icomm,iret) + & mpi_double_precision,& + & sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret info=400 @@ -170,267 +213,173 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - ! scatter elements from receivebuffer after swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - else if (swap_sync) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm < me) then - ! First I send - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) - call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) - ! Then I receive - snd_pt = brvidx(proc_to_comm) - call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) else if (proc_to_comm > me) then - ! First I receive - snd_pt = bsdidx(proc_to_comm) - call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) - ! Then I send - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) - call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) - else if (proc_to_comm == me) then - ! I send to myself - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = bsdidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do else if (swap_send .and. swap_recv) then ! First I post all the non blocking receives - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - p2ptag = krecvid(ictxt,proc_to_comm,me) - snd_pt = brvidx(proc_to_comm) - call mpi_irecv(sndbuf(snd_pt),sdsz(proc_to_comm),& - & mpi_double_precision,prcid(proc_to_comm),& - & p2ptag, icomm,rvhd(proc_to_comm),iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + p2ptag = krecvid(ictxt,proc_to_comm,me) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + call mpi_irecv(sndbuf(snd_pt),n*nesd,& + & mpi_double_precision,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 end do - ! Then I post all the blocking sends - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) - if(proc_to_comm /= me) then - p2ptag=ksendid(ictxt,proc_to_comm,me) - call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),& - & mpi_double_precision,prcid(proc_to_comm),& + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,info) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + p2ptag=ksendid(ictxt,proc_to_comm,me) + + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& + & mpi_double_precision,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),n*nerv,& + & mpi_double_precision,prcid(i),& & p2ptag,icomm,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - if(.false.) then - do i=1, totxch - call mpi_waitany(np,rvhd,ixrec,p2pstat,iret) + + pnti = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = krecvid(ictxt,proc_to_comm,me) + + if (proc_to_comm /= me) then + call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) goto 9999 end if + end if + pnti = pnti + nerv + nesd + 3 + end do - if (ixrec /= mpi_undefined) then - ixrec=ixrec-1 ! mpi_waitany returns an 1 to np index - point_to_proc = ptp(ixrec) - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - else - int_err(1) = ixrec - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm == me) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - else + else if (swap_send) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 - end if + end do - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + else if (swap_recv) then - end if + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + end if - else if (swap_send) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) - call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) + if (do_recv) then - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 end do - else if (swap_recv) then - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - snd_pt = bsdidx(proc_to_comm) - call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) - idx_pt = point_to_proc+nerv+psb_elem_send_ - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - end if + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) end if - - deallocate(sdsz,rvsz,bsdidx,& - & brvidx,rvhd,prcid,& - & ptp,stat=info) - if(all) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) if(info /= 0) then call psb_errpush(4000,name) goto 9999 @@ -449,10 +398,6 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) end subroutine psi_dswaptranm - - - - !!$ !!$ Parallel Sparse BLAS v2.0 !!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata @@ -483,7 +428,6 @@ end subroutine psi_dswaptranm !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ - subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) use psb_error_mod @@ -493,29 +437,33 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) use mpi implicit none - integer, intent(in) :: flag - integer, intent(out) :: info - real(kind(1.d0)) :: y(:), beta + integer, intent(in) :: flag + integer, intent(out) :: info + real(kind(1.d0)) :: y(:), beta real(kind(1.d0)), target :: work(:) - type(psb_desc_type) :: desc_a - integer, optional :: data + type(psb_desc_type) :: desc_a + integer, optional :: data ! locals integer :: ictxt, np, me, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& - & idxs, idxr, iret, err_act, totxch, ixrec, i, idx_pt,& - & snd_pt, rcv_pt, n + & idxs, idxr, iret, err_act, totxch, ixrec, i, & + & idx_pt, snd_pt, rcv_pt, n, pnti - integer, pointer, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, ptp, rvhd, d_idx - integer :: int_err(5) + integer, allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer, pointer :: d_idx(:) integer :: krecvid, ksendid - logical :: swap_mpi, swap_sync, swap_send, swap_recv, all + integer :: int_err(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + real(kind(1.d0)), pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name info = 0 - name='psi_dswaptranv' + name='psi_swap_tranv' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) @@ -526,100 +474,141 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) goto 9999 endif - call psb_get_mpicomm(ictxt,icomm) - - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), prcid(0:np-1),& - & ptp(0:np-1), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if (.not.psb_is_asb_dec(desc_a%matrix_data(psb_dec_type_))) then + info = 1122 + call psb_errpush(info,name) goto 9999 - end if + endif + + icomm = desc_a%matrix_data(psb_mpi_c_) + n=1 swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv if(present(data)) then if(data == psb_comm_halo_) then d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) + else if(data == psb_comm_ovr_) then d_idx => desc_a%ovrlap_index + totxch = desc_a%matrix_data(psb_tovr_xch_) + idxr = desc_a%matrix_data(psb_tovr_rcv_) + idxs = desc_a%matrix_data(psb_tovr_snd_) else d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) end if else d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) end if - idxs = 1 - idxr = 1 - totxch = 0 - point_to_proc = 1 - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - n=1 - ! prepare info for communications - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - if(proc_to_comm /= me) totxch = totxch+1 - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + idxr = idxr * n + idxs = idxs * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - ptp(proc_to_comm) = point_to_proc + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - brvidx(proc_to_comm) = idxr - rvsz(proc_to_comm) = nerv - idxr = idxr+rvsz(proc_to_comm) + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + end if - bsdidx(proc_to_comm) = idxs - sdsz(proc_to_comm) = nesd - idxs = idxs+sdsz(proc_to_comm) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do if((idxr+idxs) < size(work)) then sndbuf => work(1:idxs) rcvbuf => work(idxs+1:idxs+idxr) - all=.false. + albf=.false. else allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if - all=.true. + albf=.true. end if - ! Case SWAP_MPI - if(swap_mpi) then - ! gather elements into sendbuffer for swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 end do + end if + + ! Case SWAP_MPI + if (swap_mpi) then + ! swap elements using mpi_alltoallv call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & mpi_double_precision,sndbuf,sdsz,& - & bsdidx,mpi_double_precision,icomm,iret) + & mpi_double_precision,& + & sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret info=400 @@ -627,127 +616,96 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) goto 9999 end if - ! scatter elements from receivebuffer after swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - else if (swap_sync) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm < me) then - ! First I send - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - ! Then I receive - snd_pt = brvidx(proc_to_comm) call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) else if (proc_to_comm > me) then - ! First I receive - snd_pt = bsdidx(proc_to_comm) call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - ! Then I send - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - ! I send to myself - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = bsdidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do else if (swap_send .and. swap_recv) then ! First I post all the non blocking receives - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + p2ptag = krecvid(ictxt,proc_to_comm,me) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + call mpi_irecv(sndbuf(snd_pt),nesd,& + & mpi_double_precision,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - if (proc_to_comm /= me) then - p2ptag = krecvid(ictxt,proc_to_comm,me) - snd_pt = brvidx(proc_to_comm) - call mpi_irecv(sndbuf(snd_pt),sdsz(proc_to_comm),& - & mpi_double_precision,prcid(proc_to_comm),& - & p2ptag, icomm,rvhd(proc_to_comm),iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,info) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + p2ptag=ksendid(ictxt,proc_to_comm,me) + + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),nerv,& + & mpi_double_precision,prcid(i),& + & p2ptag, icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),nerv,& + & mpi_double_precision,prcid(i),& + & p2ptag, icomm,iret) end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - ! Then I post all the blocking sends - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - if(proc_to_comm /= me) then - p2ptag=ksendid(ictxt,proc_to_comm,me) - call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),& - & mpi_double_precision,prcid(proc_to_comm),& - & p2ptag,icomm,iret) + pnti = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + p2ptag = krecvid(ictxt,proc_to_comm,me) + + if (proc_to_comm /= me) then + call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret info=400 @@ -755,147 +713,77 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) goto 9999 end if end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + pnti = pnti + nerv + nesd + 3 end do - - if(.false.) then - do i=1, totxch - call mpi_waitany(np,rvhd,ixrec,p2pstat,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (ixrec /= mpi_undefined) then - ixrec=ixrec-1 ! mpi_waitany returns an 1 to np index - point_to_proc = ptp(ixrec) - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - else - int_err(1) = ixrec - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm == me) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - else - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - end if + else if (swap_send) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do else if (swap_recv) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - snd_pt = bsdidx(proc_to_comm) - call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - end if + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do end if - deallocate(sdsz,rvsz,bsdidx,& - & brvidx,rvhd,prcid,& - & ptp,stat=info) - if ((info==0).and. (all)) then - write(0,*) me, 'Deallocating sndbuf? ' - deallocate(sndbuf,rcvbuf,stat=info) + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) if(info /= 0) then - write(0,*) 'Error on deallocate ',info call psb_errpush(4000,name) goto 9999 end if @@ -910,5 +798,4 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) return end if return - end subroutine psi_dswaptranv diff --git a/src/internals/psi_extrct_dl.f b/src/internals/psi_extrct_dl.f index c2da81b37..5a29cda25 100644 --- a/src/internals/psi_extrct_dl.f +++ b/src/internals/psi_extrct_dl.f @@ -119,8 +119,8 @@ c desc_str list. c length_dl integer array(0:np) c length_dl(i) is the length of dep_list(*,i) list use psb_penv_mod + use psb_const_mod implicit none - include 'psb_const.fh' include 'mpif.h' c ....scalar parameters... integer np,dl_lda,mode, info diff --git a/src/internals/psi_iswapdata.f90 b/src/internals/psi_iswapdata.f90 index 3613c962a..2c745f69c 100644 --- a/src/internals/psi_iswapdata.f90 +++ b/src/internals/psi_iswapdata.f90 @@ -48,17 +48,21 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) integer :: ictxt, np, me, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & idxs, idxr, iret, err_act, totxch, ixrec, i, idx_pt,& - & snd_pt, rcv_pt + & snd_pt, rcv_pt, pnti integer :: krecvid, ksendid - integer, pointer, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, ptp, rvhd, d_idx + integer, allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer, pointer :: d_idx(:) integer :: int_err(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv, all + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + integer, pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name info = 0 - name='psi_dswap_data' + name='psi_swap_data' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) @@ -68,96 +72,130 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) call psb_errpush(info,name) goto 9999 endif - - call psb_get_mpicomm(ictxt,icomm) - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), prcid(0:np-1),& - & ptp(0:np-1), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if (.not.psb_is_asb_dec(desc_a%matrix_data(psb_dec_type_))) then + info = 1122 + call psb_errpush(info,name) goto 9999 - end if + endif + - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + icomm = desc_a%matrix_data(psb_mpi_c_) + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv if(present(data)) then if(data == psb_comm_halo_) then d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) + else if(data == psb_comm_ovr_) then d_idx => desc_a%ovrlap_index + totxch = desc_a%matrix_data(psb_tovr_xch_) + idxr = desc_a%matrix_data(psb_tovr_rcv_) + idxs = desc_a%matrix_data(psb_tovr_snd_) else d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) end if else - d_idx => desc_a%halo_index + d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) end if + idxr = idxr * n + idxs = idxs * n - idxs = 1 - idxr = 1 - totxch = 0 - point_to_proc = 1 - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 - ! prepare info for communications - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - if(proc_to_comm /= me) totxch = totxch+1 - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + ! prepare info for communications - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - ptp(proc_to_comm) = point_to_proc - brvidx(proc_to_comm) = idxr - rvsz(proc_to_comm) = n*nerv - idxr = idxr+rvsz(proc_to_comm) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - bsdidx(proc_to_comm) = idxs - sdsz(proc_to_comm) = n*nesd - idxs = idxs+sdsz(proc_to_comm) + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do if((idxr+idxs) < size(work)) then sndbuf => work(1:idxs) rcvbuf => work(idxs+1:idxs+idxr) - all=.false. + albf=.false. else allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if - all=.true. + albf=.true. end if - ! Case SWAP_MPI - if(swap_mpi) then + if (do_send) then - ! gather elements into sendbuffer for swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) + end if - call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + + ! Case SWAP_MPI + if (swap_mpi) then ! swap elements using mpi_alltoallv call mpi_alltoallv(sndbuf,sdsz,bsdidx,& @@ -170,268 +208,186 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - ! scatter elements from receivebuffer after swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - else if (swap_sync) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm < me) then - ! First I send - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) - ! Then I receive - rcv_pt = brvidx(proc_to_comm) - call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) else if (proc_to_comm > me) then - ! First I receive - rcv_pt = brvidx(proc_to_comm) - call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) - ! Then I send - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) - else if (proc_to_comm == me) then - ! I send to myself - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) end if + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - else - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do else if (swap_send .and. swap_recv) then - ! First I post all the non blocking receives - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - p2ptag = krecvid(ictxt,proc_to_comm,me) - rcv_pt = brvidx(proc_to_comm) - call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),& - & mpi_integer,prcid(proc_to_comm),& - & p2ptag, icomm,rvhd(proc_to_comm),iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + ! First I post all the non blocking receives + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = krecvid(ictxt,proc_to_comm,me) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& + & mpi_integer,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 end do + ! Then I post all the blocking sends - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if (usersend) call mpi_barrier(icomm,info) - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) - if(proc_to_comm /= me) then - p2ptag=ksendid(ictxt,proc_to_comm,me) - call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),& - & mpi_integer,prcid(proc_to_comm),& + p2ptag=ksendid(ictxt,proc_to_comm,me) + + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),n*nesd,& + & mpi_integer,prcid(i),& & p2ptag,icomm,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if + else + call mpi_send(sndbuf(snd_pt),n*nesd,& + & mpi_integer,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - if(.false.) then - do i=1, totxch - call mpi_waitany(np,rvhd,ixrec,p2pstat,iret) + + + pnti = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = krecvid(ictxt,proc_to_comm,me) + + if (proc_to_comm /= me) then + call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) goto 9999 end if + end if + pnti = pnti + nerv + nesd + 3 + end do + - if (ixrec /= mpi_undefined) then - ixrec=ixrec-1 ! mpi_waitany returns an 1 to np index - point_to_proc = ptp(ixrec) - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - else - int_err(1) = ixrec - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm == me) then - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - else + else if (swap_send) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - else - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - end if + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + end do - end if + else if (swap_recv) then - else if (swap_send) then + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + end if - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - else if (swap_recv) then + if (do_recv) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - rcv_pt = brvidx(proc_to_comm) - call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - else - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 end do end if - deallocate(sdsz,rvsz,bsdidx,& - & brvidx,rvhd,prcid,& - & ptp,stat=info) - if(all) deallocate(sndbuf,rcvbuf,stat=info) + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) if(info /= 0) then call psb_errpush(4000,name) goto 9999 @@ -499,19 +455,23 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) ! locals integer :: ictxt, np, me, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& - & idxs, idxr, iret, err_act, totxch, ixrec, i, idx_pt,& - & snd_pt, rcv_pt, n + & idxs, idxr, iret, err_act, totxch, ixrec, i, & + & idx_pt, snd_pt, rcv_pt, n, pnti - integer, pointer, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, ptp, rvhd, d_idx + integer, allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer, pointer :: d_idx(:) integer :: krecvid, ksendid integer :: int_err(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv, all + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + integer, pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name info = 0 - name='psi_dswap_datav' + name='psi_swap_datav' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) @@ -522,97 +482,132 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) goto 9999 endif - call psb_get_mpicomm(ictxt,icomm) + if (.not.psb_is_asb_dec(desc_a%matrix_data(psb_dec_type_))) then + info = 1122 + call psb_errpush(info,name) + goto 9999 + endif + icomm = desc_a%matrix_data(psb_mpi_c_) + n=1 - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), prcid(0:np-1),& - & ptp(0:np-1), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv if(present(data)) then if(data == psb_comm_halo_) then d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) + else if(data == psb_comm_ovr_) then d_idx => desc_a%ovrlap_index + totxch = desc_a%matrix_data(psb_tovr_xch_) + idxr = desc_a%matrix_data(psb_tovr_rcv_) + idxs = desc_a%matrix_data(psb_tovr_snd_) else d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) end if else d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) end if - idxs = 1 - idxr = 1 - totxch = 0 - point_to_proc = 1 - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - n=1 - ! prepare info for communications - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - if(proc_to_comm /= me) totxch = totxch+1 - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + idxr = idxr * n + idxs = idxs * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - ptp(proc_to_comm) = point_to_proc + ! prepare info for communications - brvidx(proc_to_comm) = idxr - rvsz(proc_to_comm) = n*nerv - idxr = idxr+rvsz(proc_to_comm) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + end if - bsdidx(proc_to_comm) = idxs - sdsz(proc_to_comm) = n*nesd - idxs = idxs+sdsz(proc_to_comm) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do if((idxr+idxs) < size(work)) then sndbuf => work(1:idxs) rcvbuf => work(idxs+1:idxs+idxr) - all=.false. + albf=.false. else allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if - all=.true. + albf=.true. end if - ! Case SWAP_MPI - if(swap_mpi) then - ! gather elements into sendbuffer for swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if (do_send) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& & y,sndbuf(snd_pt:snd_pt+nesd-1)) - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 end do + end if + + ! Case SWAP_MPI + if (swap_mpi) then + ! swap elements using mpi_alltoallv call mpi_alltoallv(sndbuf,sdsz,bsdidx,& & mpi_integer,rcvbuf,rvsz,& @@ -624,268 +619,170 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) goto 9999 end if - ! scatter elements from receivebuffer after swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - else if (swap_sync) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm < me) then - ! First I send - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - ! Then I receive - rcv_pt = brvidx(proc_to_comm) call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) else if (proc_to_comm > me) then - ! First I receive - rcv_pt = brvidx(proc_to_comm) call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - ! Then I send - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - ! I send to myself - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 end do - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - else - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do else if (swap_send .and. swap_recv) then - ! First I post all the non blocking receives - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - p2ptag = krecvid(ictxt,proc_to_comm,me) - rcv_pt = brvidx(proc_to_comm) - call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),& - & mpi_integer,prcid(proc_to_comm),& - & p2ptag, icomm,rvhd(proc_to_comm),iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = krecvid(ictxt,proc_to_comm,me) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + call mpi_irecv(rcvbuf(rcv_pt),nerv,& + & mpi_integer,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 end do + ! Then I post all the blocking sends - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) + if (usersend) call mpi_barrier(icomm,info) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) - if(proc_to_comm /= me) then - p2ptag=ksendid(ictxt,proc_to_comm,me) - call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),& - & mpi_integer,prcid(proc_to_comm),& + p2ptag=ksendid(ictxt,proc_to_comm,me) + + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),nesd,& + & mpi_integer,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),nesd,& + & mpi_integer,prcid(i),& & p2ptag,icomm,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 end do - if(.false.) then - do i=1, totxch - call mpi_waitany(np,rvhd,ixrec,p2pstat,iret) + pnti = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = krecvid(ictxt,proc_to_comm,me) + + if (proc_to_comm /= me) then + call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) goto 9999 end if - if (ixrec /= mpi_undefined) then - ixrec=ixrec-1 ! mpi_waitany returns an 1 to np index - point_to_proc = ptp(ixrec) - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - else - int_err(1) = ixrec - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm == me) then - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - else - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - else - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - end if - + end if + pnti = pnti + nerv + nesd + 3 + end do + else if (swap_send) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 end do else if (swap_recv) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if - if(proc_to_comm /= me) then - rcv_pt = brvidx(proc_to_comm) - call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - else - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 end do end if - deallocate(sdsz,rvsz,bsdidx,& - & brvidx,rvhd,prcid,& - & ptp,stat=info) - if(all) deallocate(sndbuf,rcvbuf,stat=info) + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) if(info /= 0) then call psb_errpush(4000,name) goto 9999 diff --git a/src/internals/psi_iswaptran.f90 b/src/internals/psi_iswaptran.f90 index 223e792aa..9a7a11eba 100644 --- a/src/internals/psi_iswaptran.f90 +++ b/src/internals/psi_iswaptran.f90 @@ -39,7 +39,7 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) integer, intent(in) :: flag, n integer, intent(out) :: info - integer :: y(:,:), beta + integer :: y(:,:), beta integer, target :: work(:) type(psb_desc_type) :: desc_a integer, optional :: data @@ -48,18 +48,21 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) integer :: ictxt, np, me, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & idxs, idxr, iret, err_act, totxch, ixrec, i, idx_pt,& - & snd_pt, rcv_pt - - integer, pointer, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, ptp, rvhd, d_idx - integer :: int_err(5) + & snd_pt, rcv_pt, pnti integer :: krecvid, ksendid - logical :: swap_mpi, swap_sync, swap_send, swap_recv, all + integer, allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer, pointer :: d_idx(:) + integer :: int_err(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + integer, pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name info = 0 - name='psi_dswaptranm' + name='psi_swap_tran' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) @@ -70,100 +73,139 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) goto 9999 endif - call psb_get_mpicomm(ictxt,icomm) - - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), prcid(0:np-1),& - & ptp(0:np-1), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if (.not.psb_is_asb_dec(desc_a%matrix_data(psb_dec_type_))) then + info = 1122 + call psb_errpush(info,name) goto 9999 - end if + endif + + + icomm = desc_a%matrix_data(psb_mpi_c_) swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv if(present(data)) then if(data == psb_comm_halo_) then d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) + else if(data == psb_comm_ovr_) then d_idx => desc_a%ovrlap_index + totxch = desc_a%matrix_data(psb_tovr_xch_) + idxr = desc_a%matrix_data(psb_tovr_rcv_) + idxs = desc_a%matrix_data(psb_tovr_snd_) else d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) end if else d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) end if + idxr = idxr * n + idxs = idxs * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) - idxs = 1 - idxr = 1 - totxch = 0 - point_to_proc = 1 - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - ! prepare info for communications - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - if(proc_to_comm /= me) totxch = totxch+1 - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - ptp(proc_to_comm) = point_to_proc + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv - brvidx(proc_to_comm) = idxr - rvsz(proc_to_comm) = n*nerv - idxr = idxr+rvsz(proc_to_comm) + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd - bsdidx(proc_to_comm) = idxs - sdsz(proc_to_comm) = n*nesd - idxs = idxs+sdsz(proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do if((idxr+idxs) < size(work)) then sndbuf => work(1:idxs) rcvbuf => work(idxs+1:idxs+idxr) - all=.false. + albf=.false. else allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if - all=.true. + albf=.true. end if - ! Case SWAP_MPI - if(swap_mpi) then - - ! gather elements into sendbuffer for swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if (do_send) then - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) + & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 end do + end if + + + + ! Case SWAP_MPI + if (swap_mpi) then + ! swap elements using mpi_alltoallv call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & mpi_integer,sndbuf,sdsz,& - & bsdidx,mpi_integer,icomm,iret) + & mpi_integer,& + & sndbuf,sdsz,bsdidx,mpi_integer,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret info=400 @@ -171,267 +213,173 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - ! scatter elements from receivebuffer after swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - else if (swap_sync) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm < me) then - ! First I send - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) - call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) - ! Then I receive - snd_pt = brvidx(proc_to_comm) - call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) else if (proc_to_comm > me) then - ! First I receive - snd_pt = bsdidx(proc_to_comm) - call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) - ! Then I send - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) - call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) - else if (proc_to_comm == me) then - ! I send to myself - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = bsdidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do else if (swap_send .and. swap_recv) then ! First I post all the non blocking receives - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - p2ptag = krecvid(ictxt,proc_to_comm,me) - snd_pt = brvidx(proc_to_comm) - call mpi_irecv(sndbuf(snd_pt),sdsz(proc_to_comm),& - & mpi_integer,prcid(proc_to_comm),& - & p2ptag, icomm,rvhd(proc_to_comm),iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + p2ptag = krecvid(ictxt,proc_to_comm,me) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + call mpi_irecv(sndbuf(snd_pt),n*nesd,& + & mpi_integer,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 end do - ! Then I post all the blocking sends - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) - if(proc_to_comm /= me) then - p2ptag=ksendid(ictxt,proc_to_comm,me) - call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),& - & mpi_integer,prcid(proc_to_comm),& + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,info) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + p2ptag=ksendid(ictxt,proc_to_comm,me) + + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& + & mpi_integer,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),n*nerv,& + & mpi_integer,prcid(i),& & p2ptag,icomm,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - if(.false.) then - do i=1, totxch - call mpi_waitany(np,rvhd,ixrec,p2pstat,iret) + + pnti = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = krecvid(ictxt,proc_to_comm,me) + + if (proc_to_comm /= me) then + call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) goto 9999 end if + end if + pnti = pnti + nerv + nesd + 3 + end do - if (ixrec /= mpi_undefined) then - ixrec=ixrec-1 ! mpi_waitany returns an 1 to np index - point_to_proc = ptp(ixrec) - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - else - int_err(1) = ixrec - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm == me) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - else + else if (swap_send) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 - end if + end do - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + else if (swap_recv) then - end if + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + end if - else if (swap_send) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) - call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) + if (do_recv) then - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 end do - else if (swap_recv) then + end if - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - snd_pt = bsdidx(proc_to_comm) - call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) - idx_pt = point_to_proc+nerv+psb_elem_send_ - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) end if - - deallocate(sdsz,rvsz,bsdidx,& - & brvidx,rvhd,prcid,& - & ptp,stat=info) - if(all) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) if(info /= 0) then call psb_errpush(4000,name) goto 9999 @@ -450,8 +398,6 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) end subroutine psi_iswaptranm - - !!$ !!$ Parallel Sparse BLAS v2.0 !!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata @@ -491,30 +437,33 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data) use mpi implicit none - integer, intent(in) :: flag - integer, intent(out) :: info - integer :: y(:), beta - integer, target :: work(:) - type(psb_desc_type) :: desc_a - integer, optional :: data + integer, intent(in) :: flag + integer, intent(out) :: info + integer :: y(:), beta + integer, target :: work(:) + type(psb_desc_type) :: desc_a + integer, optional :: data ! locals integer :: ictxt, np, me, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& - & idxs, idxr, iret, err_act, totxch, ixrec, i, idx_pt,& - & snd_pt, rcv_pt, n + & idxs, idxr, iret, err_act, totxch, ixrec, i, & + & idx_pt, snd_pt, rcv_pt, n, pnti - integer, pointer, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, ptp, rvhd, d_idx - integer :: int_err(5) + integer, allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer, pointer :: d_idx(:) integer :: krecvid, ksendid - logical :: swap_mpi, swap_sync, swap_send, swap_recv, all + integer :: int_err(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + integer, pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name - info = 0 - name='psi_dswaptranv' + name='psi_swap_tranv' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) @@ -525,98 +474,141 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data) goto 9999 endif - call psb_get_mpicomm(ictxt,icomm) - - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), prcid(0:np-1),& - & ptp(0:np-1), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if (.not.psb_is_asb_dec(desc_a%matrix_data(psb_dec_type_))) then + info = 1122 + call psb_errpush(info,name) goto 9999 - end if + endif + + icomm = desc_a%matrix_data(psb_mpi_c_) + n=1 swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv if(present(data)) then if(data == psb_comm_halo_) then d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) + else if(data == psb_comm_ovr_) then d_idx => desc_a%ovrlap_index + totxch = desc_a%matrix_data(psb_tovr_xch_) + idxr = desc_a%matrix_data(psb_tovr_rcv_) + idxs = desc_a%matrix_data(psb_tovr_snd_) else d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) end if else d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) end if - idxs = 1 - idxr = 1 - totxch = 0 - point_to_proc = 1 - rvhd(:) = mpi_request_null - n=1 - ! prepare info for communications - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - if(proc_to_comm /= me) totxch = totxch+1 - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + idxr = idxr * n + idxs = idxs * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - ptp(proc_to_comm) = point_to_proc + ! prepare info for communications - brvidx(proc_to_comm) = idxr - rvsz(proc_to_comm) = nerv - idxr = idxr+rvsz(proc_to_comm) - bsdidx(proc_to_comm) = idxs - sdsz(proc_to_comm) = nesd - idxs = idxs+sdsz(proc_to_comm) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + end if + - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do if((idxr+idxs) < size(work)) then sndbuf => work(1:idxs) rcvbuf => work(idxs+1:idxs+idxr) - all=.false. + albf=.false. else allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if - all=.true. + albf=.true. end if - ! Case SWAP_MPI - if(swap_mpi) then - ! gather elements into sendbuffer for swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 end do + end if + + ! Case SWAP_MPI + if (swap_mpi) then + ! swap elements using mpi_alltoallv call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & mpi_integer,sndbuf,sdsz,& - & bsdidx,mpi_integer,icomm,iret) + & mpi_integer,& + & sndbuf,sdsz,bsdidx,mpi_integer,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret info=400 @@ -624,127 +616,96 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data) goto 9999 end if - ! scatter elements from receivebuffer after swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - else if (swap_sync) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm < me) then - ! First I send - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - ! Then I receive - snd_pt = brvidx(proc_to_comm) call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) else if (proc_to_comm > me) then - ! First I receive - snd_pt = bsdidx(proc_to_comm) call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - ! Then I send - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - ! I send to myself - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = bsdidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do else if (swap_send .and. swap_recv) then ! First I post all the non blocking receives - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + p2ptag = krecvid(ictxt,proc_to_comm,me) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + call mpi_irecv(sndbuf(snd_pt),nesd,& + & mpi_integer,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - if (proc_to_comm /= me) then - p2ptag = krecvid(ictxt,proc_to_comm,me) - snd_pt = brvidx(proc_to_comm) - call mpi_irecv(sndbuf(snd_pt),sdsz(proc_to_comm),& - & mpi_integer,prcid(proc_to_comm),& - & p2ptag, icomm,rvhd(proc_to_comm),iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,info) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + p2ptag=ksendid(ictxt,proc_to_comm,me) + + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),nerv,& + & mpi_integer,prcid(i),& + & p2ptag, icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),nerv,& + & mpi_integer,prcid(i),& + & p2ptag, icomm,iret) end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - ! Then I post all the blocking sends - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - if(proc_to_comm /= me) then - p2ptag=ksendid(ictxt,proc_to_comm,me) - call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),& - & mpi_integer,prcid(proc_to_comm),& - & p2ptag,icomm,iret) + pnti = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + p2ptag = krecvid(ictxt,proc_to_comm,me) + + if (proc_to_comm /= me) then + call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret info=400 @@ -752,147 +713,77 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data) goto 9999 end if end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + pnti = pnti + nerv + nesd + 3 end do - if(.false.) then - do i=1, totxch - call mpi_waitany(np,rvhd,ixrec,p2pstat,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (ixrec /= mpi_undefined) then - ixrec=ixrec-1 ! mpi_waitany returns an 1 to np index - point_to_proc = ptp(ixrec) - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - else - int_err(1) = ixrec - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm == me) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - else - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - end if else if (swap_send) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do else if (swap_recv) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 - if(proc_to_comm /= me) then - snd_pt = bsdidx(proc_to_comm) - call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do end if - deallocate(sdsz,rvsz,bsdidx,& - & brvidx,rvhd,prcid,& - & ptp,stat=info) - if ((info==0).and. (all)) then - write(0,*) me, 'Deallocating sndbuf? ' - deallocate(sndbuf,rcvbuf,stat=info) + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) if(info /= 0) then - write(0,*) 'Error on deallocate ',info call psb_errpush(4000,name) goto 9999 end if diff --git a/src/internals/psi_zswapdata.f90 b/src/internals/psi_zswapdata.f90 index f64d1238e..31633fd8f 100644 --- a/src/internals/psi_zswapdata.f90 +++ b/src/internals/psi_zswapdata.f90 @@ -48,17 +48,21 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) integer :: ictxt, np, me, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & idxs, idxr, iret, err_act, totxch, ixrec, i, idx_pt,& - & snd_pt, rcv_pt + & snd_pt, rcv_pt, pnti integer :: krecvid, ksendid - integer, pointer, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, ptp, rvhd, d_idx + integer, allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer, pointer :: d_idx(:) integer :: int_err(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv, all + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + complex(kind(1.d0)), pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name info = 0 - name='psi_zswap_data' + name='psi_swap_data' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) @@ -68,96 +72,130 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) call psb_errpush(info,name) goto 9999 endif - - call psb_get_mpicomm(ictxt,icomm) - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), prcid(0:np-1),& - & ptp(0:np-1), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if (.not.psb_is_asb_dec(desc_a%matrix_data(psb_dec_type_))) then + info = 1122 + call psb_errpush(info,name) goto 9999 - end if + endif + - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + icomm = desc_a%matrix_data(psb_mpi_c_) + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv if(present(data)) then if(data == psb_comm_halo_) then d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) + else if(data == psb_comm_ovr_) then d_idx => desc_a%ovrlap_index + totxch = desc_a%matrix_data(psb_tovr_xch_) + idxr = desc_a%matrix_data(psb_tovr_rcv_) + idxs = desc_a%matrix_data(psb_tovr_snd_) else d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) end if else d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) end if + idxr = idxr * n + idxs = idxs * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if - idxs = 1 - idxr = 1 - totxch = 0 - point_to_proc = 1 - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 - ! prepare info for communications - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - if(proc_to_comm /= me) totxch = totxch+1 - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + ! prepare info for communications - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - ptp(proc_to_comm) = point_to_proc - brvidx(proc_to_comm) = idxr - rvsz(proc_to_comm) = n*nerv - idxr = idxr+rvsz(proc_to_comm) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - bsdidx(proc_to_comm) = idxs - sdsz(proc_to_comm) = n*nesd - idxs = idxs+sdsz(proc_to_comm) + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do if((idxr+idxs) < size(work)) then sndbuf => work(1:idxs) rcvbuf => work(idxs+1:idxs+idxr) - all=.false. + albf=.false. else allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if - all=.true. + albf=.true. end if - ! Case SWAP_MPI - if(swap_mpi) then + if (do_send) then - ! gather elements into sendbuffer for swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) + end if - call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + + ! Case SWAP_MPI + if (swap_mpi) then ! swap elements using mpi_alltoallv call mpi_alltoallv(sndbuf,sdsz,bsdidx,& @@ -170,268 +208,186 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - ! scatter elements from receivebuffer after swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - else if (swap_sync) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm < me) then - ! First I send - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) - ! Then I receive - rcv_pt = brvidx(proc_to_comm) - call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) else if (proc_to_comm > me) then - ! First I receive - rcv_pt = brvidx(proc_to_comm) - call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) - ! Then I send - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) - else if (proc_to_comm == me) then - ! I send to myself - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) end if + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - else - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do else if (swap_send .and. swap_recv) then - ! First I post all the non blocking receives - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - p2ptag = krecvid(ictxt,proc_to_comm,me) - rcv_pt = brvidx(proc_to_comm) - call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),& - & mpi_double_complex,prcid(proc_to_comm),& - & p2ptag, icomm,rvhd(proc_to_comm),iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + ! First I post all the non blocking receives + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = krecvid(ictxt,proc_to_comm,me) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& + & mpi_double_complex,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 end do + ! Then I post all the blocking sends - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if (usersend) call mpi_barrier(icomm,info) - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) - if(proc_to_comm /= me) then - p2ptag=ksendid(ictxt,proc_to_comm,me) - call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),& - & mpi_double_complex,prcid(proc_to_comm),& + p2ptag=ksendid(ictxt,proc_to_comm,me) + + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),n*nesd,& + & mpi_double_complex,prcid(i),& & p2ptag,icomm,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if + else + call mpi_send(sndbuf(snd_pt),n*nesd,& + & mpi_double_complex,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - if(.false.) then - do i=1, totxch - call mpi_waitany(np,rvhd,ixrec,p2pstat,iret) + + + pnti = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = krecvid(ictxt,proc_to_comm,me) + + if (proc_to_comm /= me) then + call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) goto 9999 end if + end if + pnti = pnti + nerv + nesd + 3 + end do + - if (ixrec /= mpi_undefined) then - ixrec=ixrec-1 ! mpi_waitany returns an 1 to np index - point_to_proc = ptp(ixrec) - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - else - int_err(1) = ixrec - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm == me) then - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - else + else if (swap_send) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - else - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - end if + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + end do - end if + else if (swap_recv) then - else if (swap_send) then + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + end if - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd*n-1)) - call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - else if (swap_recv) then + if (do_recv) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - rcv_pt = brvidx(proc_to_comm) - call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - else - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 end do end if - deallocate(sdsz,rvsz,bsdidx,& - & brvidx,rvhd,prcid,& - & ptp,stat=info) - if(all) deallocate(sndbuf,rcvbuf,stat=info) + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) if(info /= 0) then call psb_errpush(4000,name) goto 9999 @@ -499,19 +455,23 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) ! locals integer :: ictxt, np, me, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& - & idxs, idxr, iret, err_act, totxch, ixrec, i, idx_pt,& - & snd_pt, rcv_pt, n + & idxs, idxr, iret, err_act, totxch, ixrec, i, & + & idx_pt, snd_pt, rcv_pt, n, pnti - integer, pointer, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, ptp, rvhd, d_idx + integer, allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer, pointer :: d_idx(:) integer :: krecvid, ksendid integer :: int_err(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv,all + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + complex(kind(1.d0)), pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name info = 0 - name='psi_zswap_datav' + name='psi_swap_datav' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) @@ -522,97 +482,132 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) goto 9999 endif - call psb_get_mpicomm(ictxt,icomm) + if (.not.psb_is_asb_dec(desc_a%matrix_data(psb_dec_type_))) then + info = 1122 + call psb_errpush(info,name) + goto 9999 + endif + icomm = desc_a%matrix_data(psb_mpi_c_) + n=1 - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), prcid(0:np-1),& - & ptp(0:np-1), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv if(present(data)) then if(data == psb_comm_halo_) then d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) + else if(data == psb_comm_ovr_) then d_idx => desc_a%ovrlap_index + totxch = desc_a%matrix_data(psb_tovr_xch_) + idxr = desc_a%matrix_data(psb_tovr_rcv_) + idxs = desc_a%matrix_data(psb_tovr_snd_) else d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) end if else d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) end if - idxs = 1 - idxr = 1 - totxch = 0 - point_to_proc = 1 - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - n=1 - ! prepare info for communications - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - if(proc_to_comm /= me) totxch = totxch+1 - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + idxr = idxr * n + idxs = idxs * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - ptp(proc_to_comm) = point_to_proc + ! prepare info for communications - brvidx(proc_to_comm) = idxr - rvsz(proc_to_comm) = n*nerv - idxr = idxr+rvsz(proc_to_comm) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + end if - bsdidx(proc_to_comm) = idxs - sdsz(proc_to_comm) = n*nesd - idxs = idxs+sdsz(proc_to_comm) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do if((idxr+idxs) < size(work)) then sndbuf => work(1:idxs) rcvbuf => work(idxs+1:idxs+idxr) - all=.false. + albf=.false. else allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if - all=.true. + albf=.true. end if - ! Case SWAP_MPI - if(swap_mpi) then - ! gather elements into sendbuffer for swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if (do_send) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& & y,sndbuf(snd_pt:snd_pt+nesd-1)) - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 end do + end if + + ! Case SWAP_MPI + if (swap_mpi) then + ! swap elements using mpi_alltoallv call mpi_alltoallv(sndbuf,sdsz,bsdidx,& & mpi_double_complex,rcvbuf,rvsz,& @@ -624,268 +619,170 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) goto 9999 end if - ! scatter elements from receivebuffer after swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - else if (swap_sync) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm < me) then - ! First I send - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - ! Then I receive - rcv_pt = brvidx(proc_to_comm) call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) else if (proc_to_comm > me) then - ! First I receive - rcv_pt = brvidx(proc_to_comm) call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - ! Then I send - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - ! I send to myself - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 end do - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - else - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do else if (swap_send .and. swap_recv) then - ! First I post all the non blocking receives - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - p2ptag = krecvid(ictxt,proc_to_comm,me) - rcv_pt = brvidx(proc_to_comm) - call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),& - & mpi_double_complex,prcid(proc_to_comm),& - & p2ptag, icomm,rvhd(proc_to_comm),iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = krecvid(ictxt,proc_to_comm,me) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + call mpi_irecv(rcvbuf(rcv_pt),nerv,& + & mpi_double_complex,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 end do + ! Then I post all the blocking sends - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) + if (usersend) call mpi_barrier(icomm,info) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) - if(proc_to_comm /= me) then - p2ptag=ksendid(ictxt,proc_to_comm,me) - call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),& - & mpi_double_complex,prcid(proc_to_comm),& + p2ptag=ksendid(ictxt,proc_to_comm,me) + + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),nesd,& + & mpi_double_complex,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),nesd,& + & mpi_double_complex,prcid(i),& & p2ptag,icomm,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 end do - if(.false.) then - do i=1, totxch - call mpi_waitany(np,rvhd,ixrec,p2pstat,iret) + pnti = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = krecvid(ictxt,proc_to_comm,me) + + if (proc_to_comm /= me) then + call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) goto 9999 end if - if (ixrec /= mpi_undefined) then - ixrec=ixrec-1 ! mpi_waitany returns an 1 to np index - point_to_proc = ptp(ixrec) - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - else - int_err(1) = ixrec - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm == me) then - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - else - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - else - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - end if + end if + pnti = pnti + nerv + nesd + 3 + end do else if (swap_send) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) call psb_snd(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 end do else if (swap_recv) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if - if(proc_to_comm /= me) then - rcv_pt = brvidx(proc_to_comm) - call psb_rcv(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - else - idx_pt = point_to_proc+psb_elem_recv_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 end do end if - deallocate(sdsz,rvsz,bsdidx,& - & brvidx,rvhd,prcid,& - & ptp,stat=info) - if(all) deallocate(sndbuf,rcvbuf,stat=info) + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) if(info /= 0) then call psb_errpush(4000,name) goto 9999 diff --git a/src/internals/psi_zswaptran.f90 b/src/internals/psi_zswaptran.f90 index 5c6259194..73d614a21 100644 --- a/src/internals/psi_zswaptran.f90 +++ b/src/internals/psi_zswaptran.f90 @@ -37,29 +37,32 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) use mpi implicit none - integer, intent(in) :: flag, n - integer, intent(out) :: info - complex(kind(1.d0)) :: y(:,:), beta + integer, intent(in) :: flag, n + integer, intent(out) :: info + complex(kind(1.d0)) :: y(:,:), beta complex(kind(1.d0)), target :: work(:) - type(psb_desc_type) :: desc_a - integer, optional :: data + type(psb_desc_type) :: desc_a + integer, optional :: data ! locals integer :: ictxt, np, me, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & idxs, idxr, iret, err_act, totxch, ixrec, i, idx_pt,& - & snd_pt, rcv_pt - - integer, pointer, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, ptp, rvhd, d_idx - integer :: int_err(5) + & snd_pt, rcv_pt, pnti integer :: krecvid, ksendid - logical :: swap_mpi, swap_sync, swap_send, swap_recv, all + integer, allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer, pointer :: d_idx(:) + integer :: int_err(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + complex(kind(1.d0)), pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name info = 0 - name='psi_zswaptranm' + name='psi_swap_tran' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) @@ -70,100 +73,139 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) goto 9999 endif - call psb_get_mpicomm(ictxt,icomm) - - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), prcid(0:np-1),& - & ptp(0:np-1), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if (.not.psb_is_asb_dec(desc_a%matrix_data(psb_dec_type_))) then + info = 1122 + call psb_errpush(info,name) goto 9999 - end if + endif + + + icomm = desc_a%matrix_data(psb_mpi_c_) swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv if(present(data)) then if(data == psb_comm_halo_) then d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) + else if(data == psb_comm_ovr_) then d_idx => desc_a%ovrlap_index + totxch = desc_a%matrix_data(psb_tovr_xch_) + idxr = desc_a%matrix_data(psb_tovr_rcv_) + idxs = desc_a%matrix_data(psb_tovr_snd_) else d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) end if else d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) end if + idxr = idxr * n + idxs = idxs * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) - idxs = 1 - idxr = 1 - totxch = 0 - point_to_proc = 1 - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - ! prepare info for communications - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - if(proc_to_comm /= me) totxch = totxch+1 - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - ptp(proc_to_comm) = point_to_proc + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv - brvidx(proc_to_comm) = idxr - rvsz(proc_to_comm) = n*nerv - idxr = idxr+rvsz(proc_to_comm) + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd - bsdidx(proc_to_comm) = idxs - sdsz(proc_to_comm) = n*nesd - idxs = idxs+sdsz(proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do if((idxr+idxs) < size(work)) then sndbuf => work(1:idxs) rcvbuf => work(idxs+1:idxs+idxr) - all=.false. + albf=.false. else allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if - all=.true. + albf=.true. end if - ! Case SWAP_MPI - if(swap_mpi) then - - ! gather elements into sendbuffer for swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if (do_send) then - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) + & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 end do + end if + + + + ! Case SWAP_MPI + if (swap_mpi) then + ! swap elements using mpi_alltoallv call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & mpi_double_complex,sndbuf,sdsz,& - & bsdidx,mpi_double_complex,icomm,iret) + & mpi_double_precision,& + & sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret info=400 @@ -171,267 +213,170 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) goto 9999 end if - ! scatter elements from receivebuffer after swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - else if (swap_sync) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm < me) then - ! First I send - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) - call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) - ! Then I receive - snd_pt = brvidx(proc_to_comm) - call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) else if (proc_to_comm > me) then - ! First I receive - snd_pt = bsdidx(proc_to_comm) - call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) - ! Then I send - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) - call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) - else if (proc_to_comm == me) then - ! I send to myself - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = bsdidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do else if (swap_send .and. swap_recv) then ! First I post all the non blocking receives - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - p2ptag = krecvid(ictxt,proc_to_comm,me) - snd_pt = brvidx(proc_to_comm) - call mpi_irecv(sndbuf(snd_pt),sdsz(proc_to_comm),& - & mpi_double_complex,prcid(proc_to_comm),& - & p2ptag, icomm,rvhd(proc_to_comm),iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + p2ptag = krecvid(ictxt,proc_to_comm,me) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + call mpi_irecv(sndbuf(snd_pt),n*nesd,& + & mpi_double_complex,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) end do - ! Then I post all the blocking sends - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) - if(proc_to_comm /= me) then - p2ptag=ksendid(ictxt,proc_to_comm,me) - call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),& - & mpi_double_complex,prcid(proc_to_comm),& + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,info) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + p2ptag=ksendid(ictxt,proc_to_comm,me) + + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& + & mpi_double_complex,prcid(i),& & p2ptag,icomm,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if + else + call mpi_send(rcvbuf(rcv_pt),n*nerv,& + & mpi_double_complex,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - if(.false.) then - do i=1, totxch - call mpi_waitany(np,rvhd,ixrec,p2pstat,iret) + + pnti = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = krecvid(ictxt,proc_to_comm,me) + + if (proc_to_comm /= me) then + call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret info=400 call psb_errpush(info,name,i_err=int_err) goto 9999 end if + end if + pnti = pnti + nerv + nesd + 3 + end do - if (ixrec /= mpi_undefined) then - ixrec=ixrec-1 ! mpi_waitany returns an 1 to np index - point_to_proc = ptp(ixrec) - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - else - int_err(1) = ixrec - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm == me) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - else + else if (swap_send) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 - end if + end do - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + else if (swap_recv) then - end if + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + end if - else if (swap_send) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) - call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv*n-1), proc_to_comm) + if (do_recv) then - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 end do - else if (swap_recv) then - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - snd_pt = bsdidx(proc_to_comm) - call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd*n-1), proc_to_comm) - idx_pt = point_to_proc+nerv+psb_elem_send_ - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - end if + end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) end if - - deallocate(sdsz,rvsz,bsdidx,& - & brvidx,rvhd,prcid,& - & ptp,stat=info) - if(all) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) if(info /= 0) then call psb_errpush(4000,name) goto 9999 @@ -450,10 +395,6 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) end subroutine psi_zswaptranm - - - - !!$ !!$ Parallel Sparse BLAS v2.0 !!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata @@ -484,7 +425,6 @@ end subroutine psi_zswaptranm !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ - subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) use psb_error_mod @@ -494,29 +434,33 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) use mpi implicit none - integer, intent(in) :: flag - integer, intent(out) :: info - complex(kind(1.d0)) :: y(:), beta + integer, intent(in) :: flag + integer, intent(out) :: info + complex(kind(1.d0)) :: y(:), beta complex(kind(1.d0)), target :: work(:) - type(psb_desc_type) :: desc_a - integer, optional :: data + type(psb_desc_type) :: desc_a + integer, optional :: data ! locals integer :: ictxt, np, me, point_to_proc, nesd, nerv,& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& - & idxs, idxr, iret, err_act, totxch, ixrec, i, idx_pt,& - & snd_pt, rcv_pt, n + & idxs, idxr, iret, err_act, totxch, ixrec, i, & + & idx_pt, snd_pt, rcv_pt, n, pnti - integer, pointer, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, ptp, rvhd, d_idx - integer :: int_err(5) + integer, allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer, pointer :: d_idx(:) integer :: krecvid, ksendid - logical :: swap_mpi, swap_sync, swap_send, swap_recv, all + integer :: int_err(5) + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + complex(kind(1.d0)), pointer, dimension(:) :: sndbuf, rcvbuf character(len=20) :: name info = 0 - name='psi_zswaptranv' + name='psi_swap_tranv' call psb_erractionsave(err_act) ictxt=desc_a%matrix_data(psb_ctxt_) @@ -527,100 +471,141 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) goto 9999 endif - call psb_get_mpicomm(ictxt,icomm) - - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), prcid(0:np-1),& - & ptp(0:np-1), stat=info) - if(info /= 0) then - call psb_errpush(4000,name) + if (.not.psb_is_asb_dec(desc_a%matrix_data(psb_dec_type_))) then + info = 1122 + call psb_errpush(info,name) goto 9999 - end if + endif + + icomm = desc_a%matrix_data(psb_mpi_c_) + n=1 swap_mpi = iand(flag,psb_swap_mpi_) /= 0 swap_sync = iand(flag,psb_swap_sync_) /= 0 swap_send = iand(flag,psb_swap_send_) /= 0 swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv if(present(data)) then if(data == psb_comm_halo_) then d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) + else if(data == psb_comm_ovr_) then d_idx => desc_a%ovrlap_index + totxch = desc_a%matrix_data(psb_tovr_xch_) + idxr = desc_a%matrix_data(psb_tovr_rcv_) + idxs = desc_a%matrix_data(psb_tovr_snd_) else d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) end if else d_idx => desc_a%halo_index + totxch = desc_a%matrix_data(psb_thal_xch_) + idxr = desc_a%matrix_data(psb_thal_rcv_) + idxs = desc_a%matrix_data(psb_thal_snd_) end if - idxs = 1 - idxr = 1 - totxch = 0 - point_to_proc = 1 - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - n=1 - ! prepare info for communications - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - if(proc_to_comm /= me) totxch = totxch+1 - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + idxr = idxr * n + idxs = idxs * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - ptp(proc_to_comm) = point_to_proc - brvidx(proc_to_comm) = idxr - rvsz(proc_to_comm) = nerv - idxr = idxr+rvsz(proc_to_comm) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + end if - bsdidx(proc_to_comm) = idxs - sdsz(proc_to_comm) = nesd - idxs = idxs+sdsz(proc_to_comm) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do if((idxr+idxs) < size(work)) then sndbuf => work(1:idxs) rcvbuf => work(idxs+1:idxs+idxr) - all=.false. + albf=.false. else allocate(sndbuf(idxs),rcvbuf(idxr), stat=info) if(info /= 0) then call psb_errpush(4000,name) goto 9999 end if - all=.true. + albf=.true. end if - ! Case SWAP_MPI - if(swap_mpi) then - ! gather elements into sendbuffer for swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 end do + end if + + ! Case SWAP_MPI + if (swap_mpi) then + ! swap elements using mpi_alltoallv call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & mpi_double_complex,sndbuf,sdsz,& - & bsdidx,mpi_double_complex,icomm,iret) + & mpi_double_precision,& + & sndbuf,sdsz,bsdidx,mpi_double_precision,icomm,iret) if(iret /= mpi_success) then int_err(1) = iret info=400 @@ -628,127 +613,96 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) goto 9999 end if - ! scatter elements from receivebuffer after swapping - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - else if (swap_sync) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm < me) then - ! First I send - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - ! Then I receive - snd_pt = brvidx(proc_to_comm) call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) else if (proc_to_comm > me) then - ! First I receive - snd_pt = bsdidx(proc_to_comm) call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - ! Then I send - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - ! I send to myself - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = bsdidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do else if (swap_send .and. swap_recv) then ! First I post all the non blocking receives - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + p2ptag = krecvid(ictxt,proc_to_comm,me) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + call mpi_irecv(sndbuf(snd_pt),nesd,& + & mpi_double_complex,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - if (proc_to_comm /= me) then - p2ptag = krecvid(ictxt,proc_to_comm,me) - snd_pt = brvidx(proc_to_comm) - call mpi_irecv(sndbuf(snd_pt),sdsz(proc_to_comm),& - & mpi_double_complex,prcid(proc_to_comm),& - & p2ptag, icomm,rvhd(proc_to_comm),iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,info) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + p2ptag=ksendid(ictxt,proc_to_comm,me) + + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),nerv,& + & mpi_double_complex,prcid(i),& + & p2ptag, icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),nerv,& + & mpi_double_complex,prcid(i),& + & p2ptag, icomm,iret) + end if + + if(iret /= mpi_success) then + int_err(1) = iret + info=400 + call psb_errpush(info,name,i_err=int_err) + goto 9999 end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do - ! Then I post all the blocking sends - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - if(proc_to_comm /= me) then - p2ptag=ksendid(ictxt,proc_to_comm,me) - call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),& - & mpi_double_complex,prcid(proc_to_comm),& - & p2ptag,icomm,iret) + pnti = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + p2ptag = krecvid(ictxt,proc_to_comm,me) + + if (proc_to_comm /= me) then + call mpi_wait(rvhd(i),p2pstat,iret) if(iret /= mpi_success) then int_err(1) = iret info=400 @@ -756,147 +710,77 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) goto 9999 end if end if - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) + pnti = pnti + nerv + nesd + 3 end do - - if(.false.) then - do i=1, totxch - call mpi_waitany(np,rvhd,ixrec,p2pstat,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (ixrec /= mpi_undefined) then - ixrec=ixrec-1 ! mpi_waitany returns an 1 to np index - point_to_proc = ptp(ixrec) - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - else - int_err(1) = ixrec - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - end do - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm == me) then - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - else - - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - if(proc_to_comm /= me) then - call mpi_wait(rvhd(proc_to_comm),p2pstat,iret) - if(iret /= mpi_success) then - int_err(1) = iret - info=400 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - idx_pt = point_to_proc+nerv+psb_elem_send_ - snd_pt = bsdidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - end do - - end if + else if (swap_send) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) - - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) call psb_snd(ictxt,rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do else if (swap_recv) then - point_to_proc = 1 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) - do while (proc_to_comm /= -1) - nerv = d_idx(point_to_proc+psb_n_elem_recv_) - nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 - if(proc_to_comm /= me) then - snd_pt = bsdidx(proc_to_comm) - call psb_rcv(ictxt,sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - idx_pt = point_to_proc+psb_elem_recv_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - else - idx_pt = point_to_proc+nerv+psb_elem_send_ - rcv_pt = brvidx(proc_to_comm) - call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - end if - - point_to_proc = point_to_proc+nerv+nesd+3 - proc_to_comm = d_idx(point_to_proc+psb_proc_id_) end do end if - deallocate(sdsz,rvsz,bsdidx,& - & brvidx,rvhd,prcid,& - & ptp,stat=info) - if ((info==0).and. (all)) then - write(0,*) me, 'Deallocating sndbuf? ' - deallocate(sndbuf,rcvbuf,stat=info) + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = d_idx(pnti+psb_proc_id_) + nerv = d_idx(pnti+psb_n_elem_recv_) + nesd = d_idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= 0) then + call psb_errpush(4000,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) if(info /= 0) then - write(0,*) 'Error on deallocate ',info call psb_errpush(4000,name) goto 9999 end if diff --git a/src/modules/Makefile b/src/modules/Makefile index 301fbe327..aac914872 100644 --- a/src/modules/Makefile +++ b/src/modules/Makefile @@ -19,20 +19,22 @@ LIBDIR = ../../lib psb_realloc_mod.o : psb_error_mod.o psb_spmat_type.o : psb_realloc_mod.o psb_const_mod.o psb_error_mod.o: psb_const_mod.o -psb_const_mod.f90: psb_const.fh -psb_penv_mod.o : psb_const_mod.o psb_error_mod.o +psb_penv_mod.o: psb_const_mod.o psb_error_mod.o +psi_mod.o: psb_penv_mod.o psb_error_mod.o psb_desc_type.o +psb_methd_mod.o: psb_serial_mod.o psb_desc_type.o psb_prec_type.o +psb_sparse_mod.o: $(MODULES) $(MPFOBJS) -lib: $(MODULES) mpfobjs $(OBJS) +lib: mpfobjs $(MODULES) $(OBJS) $(AR) $(LIBDIR)/$(LIBNAME) $(MODULES) $(OBJS) $(MPFOBJS) $(RANLIB) $(LIBDIR)/$(LIBNAME) - cp *$(.mod) ./psb_const.fh ./parts.fh ../../lib + /bin/cp *$(.mod) ./parts.fh ../../lib mpfobjs: (make $(MPFOBJS) F90="$(MPF90)" FC="$(MPF90)" FCOPT="$(F90COPT)") clean: - /bin/rm -f $(MODULES) $(OBJS) *$(.mod) + /bin/rm -f $(MODULES) $(OBJS) $(MPFOBJS) *$(.mod) veryclean: clean diff --git a/src/modules/psb_const.fh b/src/modules/psb_const.fh index 8d7f56d00..ca26d5a88 100644 --- a/src/modules/psb_const.fh +++ b/src/modules/psb_const.fh @@ -57,16 +57,24 @@ integer, parameter :: psb_dec_type_=1, psb_m_=2,psb_n_=3 integer, parameter :: psb_n_row_=4, psb_n_col_=5,psb_ctxt_=6 integer, parameter :: psb_loc_to_glob_=7 - integer, parameter :: psb_mpi_c_=9,psb_mdata_size_=10 + integer, parameter :: psb_thal_xch_=11 + integer, parameter :: psb_thal_snd_=12 + integer, parameter :: psb_thal_rcv_=13 + integer, parameter :: psb_tovr_xch_=14 + integer, parameter :: psb_tovr_snd_=15 + integer, parameter :: psb_tovr_rcv_=16 + integer, parameter :: psb_mpi_c_=9,psb_mdata_size_=20 integer, parameter :: psb_desc_asb_=3099 integer, parameter :: psb_desc_bld_=psb_desc_asb_+1 integer, parameter :: psb_desc_repl_=3199 integer, parameter :: psb_desc_upd_=psb_desc_bld_+1 integer, parameter :: psb_desc_upd_asb_=psb_desc_upd_+1 + integer, parameter :: psb_hpnt_nentries_=7 ! ! Constants for desc_a handling ! + integer, parameter :: psb_upd_glbnum_=998 integer, parameter :: psb_upd_locnum_=997 integer, parameter :: psb_proc_id_=0, psb_n_elem_recv_=1 diff --git a/src/modules/psb_const_mod.f90 b/src/modules/psb_const_mod.f90 index 6d1d2f87e..87d9a2ef8 100644 --- a/src/modules/psb_const_mod.f90 +++ b/src/modules/psb_const_mod.f90 @@ -31,6 +31,109 @@ module psb_const_mod - include 'psb_const.fh' - -end module psb_const_mod + ! + ! Communication, prolongation & restriction + ! + integer, parameter :: psb_nohalo_=0, psb_halo_=4 + integer, parameter :: psb_none_=0, psb_sum_=1 + integer, parameter :: psb_avg_=2, psb_square_root_=3 + integer, parameter :: psb_swap_send_=1, psb_swap_recv_=2 + integer, parameter :: psb_swap_sync_=4, psb_swap_mpi_=8 + + ! + ! Data checks + ! + integer, parameter :: psb_deadlock_check_=0 + integer, parameter :: psb_local_mtrx_check_=1 + integer, parameter :: psb_local_comm_check_=2 + integer, parameter :: psb_consistency_check_=3 + integer, parameter :: psb_global_check_=4 + integer, parameter :: psb_order_communication_=5 + integer, parameter :: psb_change_represent_=6 + integer, parameter :: psb_loc_to_glob_check_=7 + integer, parameter :: psb_convert_halo_=1, psb_convert_ovrlap_=2 + integer, parameter :: psb_act_ret_=0, psb_act_abort_=1, no_err_=0 + ! + ! Entries and values in desc%matrix_data + ! + integer, parameter :: psb_dec_type_=1, psb_m_=2,psb_n_=3 + integer, parameter :: psb_n_row_=4, psb_n_col_=5,psb_ctxt_=6 + integer, parameter :: psb_loc_to_glob_=7 + integer, parameter :: psb_thal_xch_=11 + integer, parameter :: psb_thal_snd_=12 + integer, parameter :: psb_thal_rcv_=13 + integer, parameter :: psb_tovr_xch_=14 + integer, parameter :: psb_tovr_snd_=15 + integer, parameter :: psb_tovr_rcv_=16 + integer, parameter :: psb_mpi_c_=9,psb_mdata_size_=20 + integer, parameter :: psb_desc_asb_=3099 + integer, parameter :: psb_desc_bld_=psb_desc_asb_+1 + integer, parameter :: psb_desc_repl_=3199 + integer, parameter :: psb_desc_upd_=psb_desc_bld_+1 + integer, parameter :: psb_desc_upd_asb_=psb_desc_upd_+1 + integer, parameter :: psb_hpnt_nentries_=7 + + ! + ! Constants for desc_a handling + ! + + integer, parameter :: psb_upd_glbnum_=998 + integer, parameter :: psb_upd_locnum_=997 + integer, parameter :: psb_proc_id_=0, psb_n_elem_recv_=1 + integer, parameter :: psb_elem_recv_=2, psb_n_elem_send_=2 + integer, parameter :: psb_elem_send_=3, psb_n_ovrlp_elem_=1 + integer, parameter :: psb_ovrlp_elem_to_=2, psb_ovrlp_elem_=0 + integer, parameter :: psb_n_dom_ovr_=1 + integer, parameter :: psb_no_comm_=-1 + integer, parameter :: psb_comm_halo_=0, psb_comm_ovr_=1 + + ! + ! Queries into spmat%info + ! + integer, parameter :: psb_nztotreq_=1, psb_nzrowreq_=2 + integer, parameter :: psb_nzsizereq_=3 + ! + ! Entries and values for spmat%info + ! + + integer, parameter :: psb_nnz_=1 + integer, parameter :: psb_del_bnd_=7, psb_srtd_=8 + integer, parameter :: psb_state_=9 + integer, parameter :: psb_upd_pnt_=10 + integer, parameter :: psb_dupl_=11, psb_upd_=12 + integer, parameter :: psb_ifasize_=16 + integer, parameter :: psb_spmat_null_=0, psb_spmat_bld_=1 + integer, parameter :: psb_spmat_asb_=2, psb_spmat_upd_=4 + integer, parameter :: psb_ireg_flgs_=10, psb_ip2_=0 + integer, parameter :: psb_iflag_=2, psb_ichk_=3 + integer, parameter :: psb_nnzt_=4, psb_zero_=5,psb_ipc_=6 + integer, parameter :: psb_dupl_ovwrt_ = 0 + integer, parameter :: psb_dupl_add_ = 1 + integer, parameter :: psb_dupl_err_ = 2 + integer, parameter :: psb_dupl_def_ = psb_dupl_ovwrt_ + integer, parameter :: psb_upd_dflt_ = 0 + integer, parameter :: psb_upd_srch_ = 98764 + integer, parameter :: psb_upd_perm_ = 98765 + integer, parameter :: psb_isrtdcoo_ = 98761 + integer, parameter :: psb_maxjdrows_=8, psb_minjdrows_=4 + integer, parameter :: psb_dbleint_=2 + ! + ! Error handling + ! + integer, parameter :: act_ret=0, act_abort=1, no_err=0 + + ! + ! Handy & miscellaneous constants + ! + integer, parameter :: ione=1, izero=0 + integer, parameter :: itwo=2, ithree=3,mone=-1, psb_root_=0 + real(kind(1.d0)), parameter :: psb_colrow_=0.33, psb_percent_=0.7 + real(kind(1.d0)), parameter :: dzero=0.d0, done=1.d0 + complex(kind(1.d0)), parameter :: zzero=(0.d0,0.0d0) + complex(kind(1.d0)), parameter :: zone=(1.d0,0.0d0) + real(kind(1.d0)), parameter :: epstol=1.d-32 + + character, parameter :: psb_all_='A', psb_topdef_=' ' + character(len=5) :: psb_fidef_='CSR' + +end module psb_const_mod diff --git a/src/modules/psb_desc_type.f90 b/src/modules/psb_desc_type.f90 index 07c7225b4..6e9ff1be3 100644 --- a/src/modules/psb_desc_type.f90 +++ b/src/modules/psb_desc_type.f90 @@ -42,45 +42,47 @@ module psb_descriptor_type ! desc_type contains data for communications. type psb_desc_type - ! contain decomposition informations - integer, pointer :: matrix_data(:)=>null() - ! contain index of halo elements to send/receive - integer, pointer :: halo_index(:)=>null() - ! contain indices of boundary elements - integer, pointer :: bnd_elem(:)=>null() - ! contain index of overlap elements to send/receive - integer, pointer :: ovrlap_elem(:)=>null() - ! contain for each local overlap element, the number of times - ! that is duplicated - integer, pointer :: ovrlap_index(:)=>null() - ! contain for each local element the corresponding global index - integer, pointer :: loc_to_glob(:)=>null() - ! contain for each global element the corresponding local index, - ! if exist. - integer, pointer :: glob_to_loc (:)=>null() - ! local renumbering induced by sparse matrix storage. - integer, pointer :: lprm(:)=>null() - ! index space in case it is not just the contiguous range 1:n - integer, pointer :: idx_space(:)=>null() + ! contain decomposition informations + integer, pointer :: matrix_data(:)=>null() + ! contain index of halo elements to send/receive + integer, pointer :: halo_index(:)=>null() + ! contain indices of boundary elements + integer, pointer :: bnd_elem(:)=>null() + ! contain index of overlap elements to send/receive + integer, pointer :: ovrlap_elem(:)=>null() + ! contain for each local overlap element, the number of times + ! that is duplicated + integer, pointer :: ovrlap_index(:)=>null() + ! contain for each local element the corresponding global index + integer, pointer :: loc_to_glob(:)=>null() + ! contain for each global element the corresponding local index, + ! if exist. + integer, pointer :: glob_to_loc (:)=>null() + ! local renumbering induced by sparse matrix storage. + integer, pointer :: lprm(:)=>null() + ! index space in case it is not just the contiguous range 1:n + integer, pointer :: idx_space(:)=>null() end type psb_desc_type - + contains subroutine psb_nullify_desc(desc) type(psb_desc_type), intent(inout) :: desc - + nullify(desc%matrix_data,desc%loc_to_glob,desc%glob_to_loc,& - &desc%halo_index,desc%bnd_elem,desc%ovrlap_elem,& - &desc%ovrlap_index, desc%lprm, desc%idx_space) + & desc%halo_index,desc%bnd_elem,desc%ovrlap_elem,& + & desc%ovrlap_index, desc%lprm, desc%idx_space)!,& + ! & desc%halo_pt,desc%ovrlap_pt) end subroutine psb_nullify_desc logical function psb_is_ok_dec(dectype) integer :: dectype - + psb_is_ok_dec = ((dectype == psb_desc_asb_).or.(dectype == psb_desc_bld_).or.& - &(dectype == psb_desc_upd_).or.(dectype== psb_desc_upd_asb_)) - + & (dectype == psb_desc_upd_).or.(dectype== psb_desc_upd_asb_).or.& + & (dectype== psb_desc_repl_)) + end function psb_is_ok_dec logical function psb_is_bld_dec(dectype) @@ -106,7 +108,8 @@ contains logical function psb_is_asb_dec(dectype) integer :: dectype - psb_is_asb_dec = (dectype == psb_desc_asb_) + psb_is_asb_dec = (dectype == psb_desc_asb_).or.& + & (dectype== psb_desc_repl_) end function psb_is_asb_dec diff --git a/src/modules/psb_error_mod.f90 b/src/modules/psb_error_mod.f90 index 21159fc72..e8c54926d 100644 --- a/src/modules/psb_error_mod.f90 +++ b/src/modules/psb_error_mod.f90 @@ -352,9 +352,9 @@ contains case(150) write (0,'("indices in input array are not belonging to the calling process ",i0)')i_e_d(1) case(290) - write (0,'("Is not possible to call this routine without calling before psdalloc on the same matrix")') + write (0,'("To call this routine you must first call psb_geall on the same matrix")') case(295) - write (0,'("Is not possible to call this routine without calling before psdspalloc on the same matrix")') + write (0,'("To call this routine you must first call psb_spall on the same matrix")') case(300) write (0,'("Input argument n. ",i0," must be equal to entry n. ",i0," in array input argument n.",i0)') & & i_e_d(1),i_e_d(4),i_e_d(3) @@ -376,7 +376,7 @@ contains case(600) write (0,'("Sparse Matrix and decsriptors are in an invalid state for this subroutine call: ",i0)')i_e_d(1) case (1122) - write (0,'("Invalid state for DESC_A")') + write (0,'("Invalid state for communication descriptor")') case (1123) write (0,'("Invalid combined state for A and DESC_A")') case(1124:1999) diff --git a/src/modules/psb_realloc_mod.f90 b/src/modules/psb_realloc_mod.f90 index 01c9a56c6..5649f7207 100644 --- a/src/modules/psb_realloc_mod.f90 +++ b/src/modules/psb_realloc_mod.f90 @@ -44,7 +44,287 @@ module psb_realloc_mod module procedure psb_dreallocatez2 end Interface -Contains + Interface psb_safe_cpy + module procedure psb_icpy1d,psb_icpy2d, & + & psb_dcpy1d, psb_dcpy2d, psb_zcpy1d, psb_zcpy2d + end Interface + + +contains + + subroutine psb_icpy1d(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + Integer,pointer :: vin(:),vout(:) + integer :: info + ! ...Local Variables + + Integer :: isz,err_act + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_cpy1d' + call psb_erractionsave(err_act) + + if(psb_get_errstatus().ne.0) return + info = 0 + if (associated(vin)) then + isz = size(vin) + call psb_realloc(isz,vout,info) + if (info /= 0) then + info=4010 + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act.eq.act_ret) then + return + else + call psb_error() + end if + return + + end subroutine psb_icpy1d + + subroutine psb_icpy2d(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + Integer,pointer :: vin(:,:),vout(:,:) + integer :: info + ! ...Local Variables + + Integer :: isz1, isz2,err_act + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_cpy1d' + call psb_erractionsave(err_act) + + if(psb_get_errstatus().ne.0) return + info = 0 + if (associated(vin)) then + isz1 = size(vin,1) + isz2 = size(vin,2) + call psb_realloc(isz1,isz2,vout,info) + if (info /= 0) then + info=4010 + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act.eq.act_ret) then + return + else + call psb_error() + end if + return + + end subroutine psb_icpy2d + + subroutine psb_dcpy1d(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(kind(1.d0)),pointer :: vin(:),vout(:) + integer :: info + ! ...Local Variables + + Integer :: isz,err_act + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_cpy1d' + call psb_erractionsave(err_act) + + if(psb_get_errstatus().ne.0) return + info = 0 + if (associated(vin)) then + isz = size(vin) + call psb_realloc(isz,vout,info) + if (info /= 0) then + info=4010 + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act.eq.act_ret) then + return + else + call psb_error() + end if + return + + end subroutine psb_dcpy1d + + subroutine psb_dcpy2d(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(kind(1.d0)),pointer :: vin(:,:),vout(:,:) + integer :: info + ! ...Local Variables + + Integer :: isz1, isz2,err_act + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_cpy1d' + call psb_erractionsave(err_act) + + if(psb_get_errstatus().ne.0) return + info = 0 + if (associated(vin)) then + isz1 = size(vin,1) + isz2 = size(vin,2) + call psb_realloc(isz1,isz2,vout,info) + if (info /= 0) then + info=4010 + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act.eq.act_ret) then + return + else + call psb_error() + end if + return + + end subroutine psb_dcpy2d + + subroutine psb_zcpy1d(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(kind(1.d0)),pointer :: vin(:),vout(:) + integer :: info + ! ...Local Variables + + Integer :: isz,err_act + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_cpy1d' + call psb_erractionsave(err_act) + + if(psb_get_errstatus().ne.0) return + info = 0 + if (associated(vin)) then + isz = size(vin) + call psb_realloc(isz,vout,info) + if (info /= 0) then + info=4010 + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act.eq.act_ret) then + return + else + call psb_error() + end if + return + + end subroutine psb_zcpy1d + + subroutine psb_zcpy2d(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(kind(1.d0)),pointer :: vin(:,:),vout(:,:) + integer :: info + ! ...Local Variables + + Integer :: isz1, isz2,err_act + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_cpy1d' + call psb_erractionsave(err_act) + + if(psb_get_errstatus().ne.0) return + info = 0 + if (associated(vin)) then + isz1 = size(vin,1) + isz2 = size(vin,2) + call psb_realloc(isz1,isz2,vout,info) + if (info /= 0) then + info=4010 + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act.eq.act_ret) then + return + else + call psb_error() + end if + return + + end subroutine psb_zcpy2d + Subroutine psb_dreallocate1i(len,rrax,info,pad) use psb_error_mod @@ -120,9 +400,6 @@ Contains End Subroutine psb_dreallocate1i - - - Subroutine psb_dreallocate1d(len,rrax,info,pad) use psb_error_mod @@ -154,7 +431,6 @@ Contains goto 9999 end if m = min(dim,len) -!!$ write(0,*) 'DA: copying ',min(len,dim) if (.true.) then do i=1,m tmp(i) = rrax(i) @@ -162,7 +438,6 @@ Contains else tmp(1:m) = rrax(1:m) end if -!!$ write(0,*) 'DA: copying done ',m Deallocate(rrax,stat=info) if (info /= 0) then err=4000 diff --git a/src/modules/psb_spmat_type.f90 b/src/modules/psb_spmat_type.f90 index aee7906ce..3996a96ad 100644 --- a/src/modules/psb_spmat_type.f90 +++ b/src/modules/psb_spmat_type.f90 @@ -393,27 +393,18 @@ contains Integer, intent(out) :: info !locals - Integer :: nza,nz1, nz2, nzl, nzr - logical, parameter :: debug=.false. INFO = 0 - - nza = size(a%aspk) - nz1 = size(a%ia1) - nz2 = size(a%ia2) - nzl = size(a%pl) - nzr = size(a%pr) - allocate(b%aspk(nza),b%ia1(nz1),b%ia2(nz2),& - & b%pl(nzl),b%pr(nzr),stat=info) + call psb_nullify_sp(b) + call psb_safe_cpy(a%aspk,b%aspk,info) + if (info == 0) call psb_safe_cpy(a%ia1,b%ia1,info) + if (info == 0) call psb_safe_cpy(a%ia2,b%ia2,info) + if (info == 0) call psb_safe_cpy(a%pl,b%pl,info) + if (info == 0) call psb_safe_cpy(a%pr,b%pr,info) if (info /= 0) then info=2023 return Endif - b%aspk(:) = a%aspk(:) - b%ia1(:) = a%ia1(:) - b%ia2(:) = a%ia2(:) - b%pl(:) = a%pl(:) - b%pr(:) = a%pr(:) b%infoa(:) = a%infoa(:) b%fida = a%fida b%descra = a%descra @@ -913,27 +904,21 @@ contains Integer, intent(out) :: info !locals - Integer :: nza,nz1, nz2, nzl, nzr + logical, parameter :: debug=.false. - INFO = 0 - nza = size(a%aspk) - nz1 = size(a%ia1) - nz2 = size(a%ia2) - nzl = size(a%pl) - nzr = size(a%pr) - allocate(b%aspk(nza),b%ia1(nz1),b%ia2(nz2),& - & b%pl(nzl),b%pr(nzr),stat=info) + INFO = 0 + call psb_nullify_sp(b) + call psb_safe_cpy(a%aspk,b%aspk,info) + if (info == 0) call psb_safe_cpy(a%ia1,b%ia1,info) + if (info == 0) call psb_safe_cpy(a%ia2,b%ia2,info) + if (info == 0) call psb_safe_cpy(a%pl,b%pl,info) + if (info == 0) call psb_safe_cpy(a%pr,b%pr,info) if (info /= 0) then info=2023 return Endif - b%aspk(:) = a%aspk(:) - b%ia1(:) = a%ia1(:) - b%ia2(:) = a%ia2(:) - b%pl(:) = a%pl(:) - b%pr(:) = a%pr(:) b%infoa(:) = a%infoa(:) b%fida = a%fida b%descra = a%descra diff --git a/src/modules/psi_mod.f90 b/src/modules/psi_mod.f90 index 5f6739290..d1f915e40 100644 --- a/src/modules/psi_mod.f90 +++ b/src/modules/psi_mod.f90 @@ -51,10 +51,10 @@ module psi_mod end interface interface - subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info) + subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info) use psb_descriptor_type type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info + integer, intent(out) :: info,nxch,nsnd,nrcv integer, intent(in) :: index_in(:) integer, pointer :: index_out(:) logical :: glob_idx @@ -70,12 +70,12 @@ module psi_mod interface subroutine psi_desc_index(desc_data,index_in,dep_list,& - & length_dl,loc_to_glob,glob_to_loc,desc_index,& + & length_dl,nsnd,nrcv,loc_to_glob,glob_to_loc,desc_index,& & isglob_in,info) integer :: desc_data(:),index_in(:),dep_list(:) integer :: loc_to_glob(:),glob_to_loc(:) integer,pointer :: desc_index(:) - integer :: length_dl, info + integer :: length_dl,nsnd,nrcv, info logical :: isglob_in end subroutine psi_desc_index end interface @@ -238,4 +238,104 @@ module psi_mod end subroutine psi_zsctv end interface + interface psi_cnv_dsc + module procedure psi_cnv_dsc + end interface + + +contains + + subroutine psi_cnv_dsc(halo_in,ovrlap_in,cdesc, info) + + use psb_const_mod + use psb_error_mod + use psb_penv_mod + use psb_descriptor_type + implicit none + + ! ....scalars parameters.... + integer, intent(in) :: halo_in(:), ovrlap_in(:) + type(psb_desc_type), intent(inout) :: cdesc + integer, intent(out) :: info + + ! ....local scalars.... + integer :: i,np,me,proc, max_index + integer :: ictxt, err_act,nxch,nsnd,nrcv + ! ...local array... + integer :: int_err(5) + integer, pointer :: idx_out(:) + + ! ...parameters + logical, parameter :: debug=.false. + character(len=20) :: name + + name='psi_bld_cdesc' + call psb_get_erraction(err_act) + + info = 0 + ictxt = cdesc%matrix_data(psb_ctxt_) + + call psb_info(ictxt,me,np) + if (np == -1) then + info = 2010 + call psb_errpush(info,name) + goto 9999 + endif + + + ! first the halo index + if (debug) write(0,*) me,'Calling crea_index on halo' + idx_out => null() + call psi_crea_index(cdesc,halo_in, idx_out,.false.,nxch,nsnd,nrcv,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='psi_crea_index') + goto 9999 + end if + cdesc%halo_index => idx_out + cdesc%matrix_data(psb_thal_xch_) = nxch + cdesc%matrix_data(psb_thal_snd_) = nsnd + cdesc%matrix_data(psb_thal_rcv_) = nrcv + + if (debug) write(0,*) me,'Done crea_index on halo' + if (debug) write(0,*) me,'Calling crea_index on ovrlap' + + ! then the overlap index + idx_out => null() + call psi_crea_index(cdesc,ovrlap_in, idx_out,.true.,nxch,nsnd,nrcv,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='psi_crea_index') + goto 9999 + end if + cdesc%ovrlap_index => idx_out + cdesc%matrix_data(psb_tovr_xch_) = nxch + cdesc%matrix_data(psb_tovr_snd_) = nsnd + cdesc%matrix_data(psb_tovr_rcv_) = nrcv + + if (debug) write(0,*) me,'Calling crea_ovr_elem' + ! next ovrlap_elem + call psi_crea_ovr_elem(cdesc%ovrlap_index,cdesc%ovrlap_elem) + if (debug) write(0,*) me,'Done crea_ovr_elem' + + ! finally bnd_elem + call psi_crea_bnd_elem(cdesc,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='psi_crea_bnd_elem') + goto 9999 + end if + if (debug) write(0,*) me,'Done crea_bnd_elem' + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == act_abort) then + call psb_error(ictxt) + return + end if + return + + end subroutine psi_cnv_dsc + + end module psi_mod diff --git a/src/prec/psb_dbldaggrmat.f90 b/src/prec/psb_dbldaggrmat.f90 index 5786b27cd..3c905043b 100644 --- a/src/prec/psb_dbldaggrmat.f90 +++ b/src/prec/psb_dbldaggrmat.f90 @@ -243,6 +243,10 @@ contains if (p%iprcparm(coarse_mat_) == mat_repl_) then call psb_cdrep(ntaggr,ictxt,desc_p,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='psb_cdrep') + goto 9999 + end if nzbr(:) = 0 nzbr(me+1) = irs @@ -287,6 +291,12 @@ contains else if (p%iprcparm(coarse_mat_) == mat_distr_) then call psb_cddec(naggr,ictxt,desc_p,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='psb_cddec') + goto 9999 + end if + + call psb_sp_clone(b,bg,info) if(info /= 0) then call psb_errpush(4010,name,a_err='spclone') @@ -916,6 +926,10 @@ contains nzbr(me+1) = b%infoa(psb_nnz_) call psb_cdrep(ntaggr,ictxt,desc_p,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='psb_cdrep') + goto 9999 + end if call psb_sum(ictxt,nzbr(1:np)) nzbg = sum(nzbr) @@ -970,6 +984,10 @@ contains goto 9999 end if call psb_cddec(naggr,ictxt,desc_p,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='psb_cddec') + goto 9999 + end if call psb_sp_free(b,info) if(info /= 0) then @@ -985,6 +1003,10 @@ contains nzbr(me+1) = b%infoa(psb_nnz_) call psb_cdrep(ntaggr,ictxt,desc_p,info) + if(info /= 0) then + call psb_errpush(4010,name,a_err='psb_cdrep') + goto 9999 + end if call psb_sum(ictxt,nzbr(1:np)) diff --git a/src/serial/dp/check_dim.f b/src/serial/dp/check_dim.f index 51b569d48..6ee252a33 100644 --- a/src/serial/dp/check_dim.f +++ b/src/serial/dp/check_dim.f @@ -31,8 +31,8 @@ C SUBROUTINE CHECK_DIM(M, N, IA, NG, IA2, + NZ, LARN, LIAN1, LIAN2, IERRV) + use psb_const_mod IMPLICIT NONE - INCLUDE 'psb_const.fh' C C .. Scalar Arguments .. diff --git a/src/serial/dp/dcoco.f b/src/serial/dp/dcoco.f index b922c1b10..506d76dae 100644 --- a/src/serial/dp/dcoco.f +++ b/src/serial/dp/dcoco.f @@ -34,8 +34,8 @@ c * p1,descrn,arn,ia1n,ia2n,infon,p2,larn,lia1n, * lia2n,aux,laux,ierror) + use psb_const_mod implicit none - include 'psb_const.fh' c .. scalar arguments .. integer larn, laux, lia1n, lia2n, diff --git a/src/serial/dp/dcocr.f b/src/serial/dp/dcocr.f index c72662dd5..912befea2 100644 --- a/src/serial/dp/dcocr.f +++ b/src/serial/dp/dcocr.f @@ -35,8 +35,8 @@ C * P1,DESCRN,ARN,IAN1,IAN2,INFON,P2,LARN,LIAN1, * LIAN2,AUX,LAUX,IERROR) + use psb_const_mod IMPLICIT NONE - INCLUDE 'psb_const.fh' C C .. Scalar Arguments .. diff --git a/src/serial/dp/dcrco.f b/src/serial/dp/dcrco.f index a66557624..dcc5019d4 100644 --- a/src/serial/dp/dcrco.f +++ b/src/serial/dp/dcrco.f @@ -32,8 +32,8 @@ C * IP1,DESCRN,ARN,IAN1,IAN2,INFON,IP2,LARN,LIAN1, * LIAN2,AUX,LAUX,IERROR) + use psb_const_mod IMPLICIT NONE - INCLUDE 'psb_const.fh' C C .. Scalar Arguments .. diff --git a/src/serial/dp/dcrjd.f b/src/serial/dp/dcrjd.f index d3908463e..0b11e31e8 100644 --- a/src/serial/dp/dcrjd.f +++ b/src/serial/dp/dcrjd.f @@ -59,8 +59,8 @@ C DESCRN Output matrix in JAD format C ARN,IAN1 C IAN2,INFON, IP1, IP2 C + use psb_const_mod IMPLICIT NONE - INCLUDE 'psb_const.fh' C C .. Scalar Arguments .. diff --git a/src/serial/dp/dcsrp1.f b/src/serial/dp/dcsrp1.f index 48feb10f7..99b49d4a0 100644 --- a/src/serial/dp/dcsrp1.f +++ b/src/serial/dp/dcsrp1.f @@ -116,8 +116,8 @@ C C SUBROUTINE DCSRP1(TRANS,M,N,DESCRA,JA,IA, + P,WORK,IWORK,LWORK,IERROR) + use psb_const_mod IMPLICIT NONE - INCLUDE 'psb_const.fh' C .. Scalar Arguments .. INTEGER LWORK,M, N, IERROR CHARACTER TRANS diff --git a/src/serial/dp/dgind_tri.f b/src/serial/dp/dgind_tri.f index 81b48c37f..3589f87bd 100644 --- a/src/serial/dp/dgind_tri.f +++ b/src/serial/dp/dgind_tri.f @@ -31,8 +31,8 @@ C SUBROUTINE DGIND_TRI(M,N_BLOCKS,A,IA1,IA2,ARN,KA,IA,JA, + LARN,LKA,LJA,IPERM,WORK, LWORK, IERROR) + use psb_const_mod IMPLICIT NONE - INCLUDE 'psb_const.fh' C ... Scalar arguments ... diff --git a/src/serial/dp/dgindex.f b/src/serial/dp/dgindex.f index 9b8a96daf..d1212dbb8 100644 --- a/src/serial/dp/dgindex.f +++ b/src/serial/dp/dgindex.f @@ -31,8 +31,8 @@ C SUBROUTINE DGINDEX(M,N_BLOCKS,A,IA1,IA2,ARN,KA,IA,JA, INFON, + LARN,LKA,LJA,IPERM,WORK, LWORK, SIZE_REQ, IERROR) + use psb_const_mod IMPLICIT NONE - INCLUDE 'psb_const.fh' C ... Scalar arguments ... INTEGER M, LWORK,N_BLOCKS,LARN,LKA,LJA, diff --git a/src/serial/dp/djdco.f b/src/serial/dp/djdco.f index ff2851f02..2216e292b 100644 --- a/src/serial/dp/djdco.f +++ b/src/serial/dp/djdco.f @@ -31,8 +31,8 @@ C SUBROUTINE DJDCO(TRANS,M,N,DESCRA,AR,IA1,IA2,IPERM,INFO, * IP1,DESCRN,ARN,IA1N,IA2N,INFON,IP2,LARN,LIA1N, * LIA2N,AUX,LAUX,IERROR) + use psb_const_mod IMPLICIT NONE - INCLUDE 'psb_const.fh' C C .. Scalar Arguments .. INTEGER LARN, LAUX, LIA1N, LIA2N, M, N, IERROR diff --git a/src/serial/dp/djdcox.f b/src/serial/dp/djdcox.f index a451761da..87772e17b 100755 --- a/src/serial/dp/djdcox.f +++ b/src/serial/dp/djdcox.f @@ -36,8 +36,8 @@ C * IP1,DESCRN,ARN,IA1N,IA2N,INFON,IP2,LARN,LIA1N, * LIA2N,AUX,LAUX,IERROR) + use psb_const_mod IMPLICIT NONE - INCLUDE 'psb_const.fh' C C .. Scalar Arguments .. diff --git a/src/serial/dp/gen_block.f b/src/serial/dp/gen_block.f index 5208a61cf..7fa5f79b5 100644 --- a/src/serial/dp/gen_block.f +++ b/src/serial/dp/gen_block.f @@ -29,9 +29,9 @@ C POSSIBILITY OF SUCH DAMAGE. C C SUBROUTINE GEN_BLOCK(M,NG,IA,AUX) + use psb_const_mod IMPLICIT NONE - INCLUDE 'psb_const.fh' INTEGER M, NG INTEGER IA(3,*), AUX(*) diff --git a/src/serial/dp/partition.f b/src/serial/dp/partition.f index 48708a6da..85e6ff618 100644 --- a/src/serial/dp/partition.f +++ b/src/serial/dp/partition.f @@ -29,9 +29,9 @@ C POSSIBILITY OF SUCH DAMAGE. C C SUBROUTINE PARTITION(M, WORK, IA, N_BLOCK) + use psb_const_mod IMPLICIT NONE - INCLUDE 'psb_const.fh' C ...Scalar arguments... diff --git a/src/serial/dp/zcoco.f b/src/serial/dp/zcoco.f index c41afe518..a47bc7b21 100644 --- a/src/serial/dp/zcoco.f +++ b/src/serial/dp/zcoco.f @@ -34,8 +34,8 @@ c * p1,descrn,arn,ia1n,ia2n,infon,p2,larn,lia1n, * lia2n,aux,laux,ierror) + use psb_const_mod implicit none - include 'psb_const.fh' c .. scalar arguments .. integer larn, laux, lia1n, lia2n, diff --git a/src/serial/dp/zcocr.f b/src/serial/dp/zcocr.f index ef0d4fd5a..a5d4aa769 100644 --- a/src/serial/dp/zcocr.f +++ b/src/serial/dp/zcocr.f @@ -35,8 +35,8 @@ C * P1,DESCRN,ARN,IAN1,IAN2,INFON,P2,LARN,LIAN1, * LIAN2,AUX,LAUX,IERROR) + use psb_const_mod IMPLICIT NONE - INCLUDE 'psb_const.fh' C C .. Scalar Arguments .. diff --git a/src/serial/dp/zcrco.f b/src/serial/dp/zcrco.f index a32bc9578..0ac2317c4 100644 --- a/src/serial/dp/zcrco.f +++ b/src/serial/dp/zcrco.f @@ -32,8 +32,8 @@ C * IP1,DESCRN,ARN,IAN1,IAN2,INFON,IP2,LARN,LIAN1, * LIAN2,AUX,LAUX,IERROR) + use psb_const_mod IMPLICIT NONE - INCLUDE 'psb_const.fh' C C .. Scalar Arguments .. diff --git a/src/serial/dp/zcrjd.f b/src/serial/dp/zcrjd.f index 6b48ee472..360fde795 100644 --- a/src/serial/dp/zcrjd.f +++ b/src/serial/dp/zcrjd.f @@ -59,8 +59,8 @@ C DESCRN Output matrix in JAD format C ARN,IAN1 C IAN2,INFON, IP1, IP2 C + use psb_const_mod IMPLICIT NONE - INCLUDE 'psb_const.fh' C C .. Scalar Arguments .. diff --git a/src/serial/dp/zgind_tri.f b/src/serial/dp/zgind_tri.f index 4bbdb673e..c7e71d7b6 100644 --- a/src/serial/dp/zgind_tri.f +++ b/src/serial/dp/zgind_tri.f @@ -31,8 +31,8 @@ C SUBROUTINE ZGIND_TRI(M,N_BLOCKS,A,IA1,IA2,ARN,KA,IA,JA, + LARN,LKA,LJA,IPERM,WORK, LWORK, IERROR) + use psb_const_mod IMPLICIT NONE - INCLUDE 'psb_const.fh' C ... Scalar arguments ... diff --git a/src/serial/dp/zgindex.f b/src/serial/dp/zgindex.f index f5c8f9a7f..256faa52b 100644 --- a/src/serial/dp/zgindex.f +++ b/src/serial/dp/zgindex.f @@ -31,8 +31,8 @@ C SUBROUTINE ZGINDEX(M,N_BLOCKS,A,IA1,IA2,ARN,KA,IA,JA, INFON, + LARN,LKA,LJA,IPERM,WORK, LWORK, SIZE_REQ, IERROR) + use psb_const_mod IMPLICIT NONE - INCLUDE 'psb_const.fh' C ... Scalar arguments ... INTEGER M, LWORK,N_BLOCKS,LARN,LKA,LJA, diff --git a/src/serial/f77/dcsmm.f b/src/serial/f77/dcsmm.f index a379cc69e..740607274 100644 --- a/src/serial/f77/dcsmm.f +++ b/src/serial/f77/dcsmm.f @@ -190,8 +190,8 @@ C C SUBROUTINE DCSMM(TRANS,M,N,K,ALPHA,PL,FIDA,DESCRA,A,IA1,IA2, & INFOA,PR,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + use psb_const_mod IMPLICIT NONE - INCLUDE 'psb_const.fh' C .. Scalar Arguments .. INTEGER M,N,K,LDB,LDC,LWORK, IERROR diff --git a/src/serial/jad/djadnr.f b/src/serial/jad/djadnr.f index 50e2136c8..1c1927e00 100644 --- a/src/serial/jad/djadnr.f +++ b/src/serial/jad/djadnr.f @@ -31,8 +31,8 @@ C C ... Compute infinity norma for sparse matrix in CSR Format ... DOUBLE PRECISION FUNCTION DJADNR(TRANS,M,N,NG,A,KA,JA,IA, + INFOA,IERROR) + use psb_const_mod IMPLICIT NONE - INCLUDE 'psb_const.fh' C .. Scalar Arguments .. INTEGER M,N, IERROR, NG CHARACTER TRANS diff --git a/src/serial/jad/djadrws.f b/src/serial/jad/djadrws.f index 4a8a1c4ac..0d2cf19e4 100644 --- a/src/serial/jad/djadrws.f +++ b/src/serial/jad/djadrws.f @@ -31,8 +31,8 @@ C C ... Compute infinity norma for sparse matrix in CSR Format ... SUBROUTINE DJADRWS(TRANS,M,N,NG,A,KA,JA,IA, + INFOA,ROWSUM,IERROR) + use psb_const_mod IMPLICIT NONE - INCLUDE 'psb_const.fh' C .. Scalar Arguments .. INTEGER M,N, IERROR, NG CHARACTER TRANS diff --git a/src/tools/psb_cdasb.f90 b/src/tools/psb_cdasb.f90 index 2ec881435..992361c0f 100644 --- a/src/tools/psb_cdasb.f90 +++ b/src/tools/psb_cdasb.f90 @@ -52,8 +52,8 @@ subroutine psb_cdasb(desc_a,info) !....Locals.... integer :: int_err(5), itemp(2) - integer,pointer :: ovrlap_index(:),halo_index(:),ovrlap_out(:),halo_out(:) - integer :: i,err,np,me,& + integer,pointer :: ovrlap_index(:),halo_index(:) + integer :: i,err,np,me,& & lovrlap,lhalo,nhalo,novrlap,max_size,max_halo,n_col,ldesc_halo,& & ldesc_ovrlap, dectype, err_act integer :: ictxt,n_row @@ -105,106 +105,28 @@ subroutine psb_cdasb(desc_a,info) call psb_realloc(desc_a%matrix_data(psb_n_col_),desc_a%loc_to_glob,info) - ! comm desc_size is size requested for temporary comm descriptors - ! (expressed in No of dble element) - ldesc_halo = (((3*(n_col-n_row)+1)+1)) ovrlap_index => desc_a%ovrlap_index - nullify(desc_a%ovrlap_index,ovrlap_out) - halo_index => desc_a%halo_index - nullify(desc_a%halo_index,halo_out) + nullify(desc_a%ovrlap_index) + halo_index => desc_a%halo_index + nullify(desc_a%halo_index) - lhalo = 1 - do while (halo_index(lhalo) /= -1) - lhalo = lhalo + 1 - enddo - nhalo = (lhalo-1)/3 - lovrlap=1 - do while (ovrlap_index(lovrlap) /= -1) - lovrlap=lovrlap+1 - enddo - novrlap = (lovrlap-1)/3 - - ! Allocate final comm PSBLAS descriptors - ! compute necessary dimension of halo index - max_halo = max(nhalo,1) - max_size = max(1,min(3*desc_a%matrix_data(psb_n_row_),novrlap*3)) - - itemp(1) = max_size - itemp(2) = max_halo - call psb_amx(ictxt, itemp(1:2)) - max_size = itemp(1) - max_halo = itemp(2) - - ldesc_halo = 3*max_halo+3*nhalo+1 - - ! allocate HALO_INDEX field - call psb_realloc(ldesc_halo, halo_out, info) - ! check on allocate - if (info /= no_err) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - ! compute necessary dimension of ovrlap index - ldesc_ovrlap = 2*lovrlap+1 - - ! allocate OVRLAP_INDEX field - call psb_realloc(ldesc_ovrlap, ovrlap_out, info) - ! check on allocate - if (info /= no_err) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - - - if (debug) write(0,*) 'psb_cdasb: converting indexes',& - & nhalo,lhalo,halo_index(lhalo) - !.... convert comunication stuctures.... - ! first the halo index - - call psi_crea_index(desc_a,halo_index,& - & halo_out,.false.,info) - if(info.ne.0) then - call psb_errpush(4010,name,a_err='psi_crea_index') - goto 9999 - end if - desc_a%halo_index => halo_out - - ! then the overlap index - call psi_crea_index(desc_a,ovrlap_index,& - & ovrlap_out,.true.,info) - if(info.ne.0) then - call psb_errpush(4010,name,a_err='psi_crea_index') - goto 9999 - end if - desc_a%ovrlap_index => ovrlap_out - - ! next is the ovrlap_elem index - call psi_crea_ovr_elem(desc_a%ovrlap_index,desc_a%ovrlap_elem) - - ! finally bnd_elem - call psi_crea_bnd_elem(desc_a,info) - if(info.ne.0) then - call psb_errpush(4010,name,a_err='psi_crea_bnd_elem') + call psi_cnv_dsc(halo_index,ovrlap_index,desc_a,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psi_bld_cdesc') goto 9999 end if + ! Ok, register into MATRIX_DATA & free temporary work areas desc_a%matrix_data(psb_dec_type_) = psb_desc_asb_ - deallocate(ovrlap_index, stat=info) - deallocate(halo_index, stat=info) + deallocate(ovrlap_index, halo_index, stat=info) if (info /= 0) then info =4000 call psb_errpush(info,name) goto 9999 end if - + else info = 600 call psb_errpush(info,name) diff --git a/src/tools/psb_cdcpy.f90 b/src/tools/psb_cdcpy.f90 index 052023133..dbbb62984 100644 --- a/src/tools/psb_cdcpy.f90 +++ b/src/tools/psb_cdcpy.f90 @@ -54,7 +54,7 @@ subroutine psb_cdcpy(desc_in, desc_out, info) integer, intent(out) :: info !locals - integer :: np,me,ictxt, isz, err_act + integer :: np,me,ictxt, isz, err_act, isz1, isz2 logical, parameter :: debug=.false.,debugprt=.false. character(len=20) :: name, char_err if (debug) write(0,*) me,'Entered CDCPY' @@ -62,162 +62,37 @@ subroutine psb_cdcpy(desc_in, desc_out, info) info = 0 call psb_erractionsave(err_act) name = 'psb_cdcpy' - + ictxt=desc_in%matrix_data(psb_ctxt_) ! check on blacs grid call psb_info(ictxt, me, np) if (debug) write(0,*) me,'Entered CDCPY' if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 + info = 2010 + call psb_errpush(info,name) + goto 9999 endif call psb_nullify_desc(desc_out) - if (associated(desc_in%matrix_data)) then - isz = size(desc_in%matrix_data) - ! allocate(desc_out%matrix_data(isz),stat=info) - call psb_realloc(isz,desc_out%matrix_data,info) - if(debug) write(0,*) 'cdcpy: m_data',isz,':',desc_in%matrix_data(:) - if (info /= 0) then - info=4010 - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - desc_out%matrix_data(:) = desc_in%matrix_data(:) - endif - endif - if (debug) write(0,*) me,'Done matrix_data ' - - if (associated(desc_in%halo_index)) then - isz = size(desc_in%halo_index) - ! allocate(desc_out%matrix_data(isz),stat=info) - call psb_realloc(isz,desc_out%halo_index,info) - if(debugprt) write(0,*) 'cdcpy: h_idx',isz,':',desc_in%halo_index(:) - if (info /= 0) then - info=4010 - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - desc_out%halo_index(:) = desc_in%halo_index(:) - endif - endif - if (debug) write(0,*) me,'Done halo_index' + call psb_safe_cpy(desc_in%matrix_data,desc_out%matrix_data,info) + if (info == 0) call psb_safe_cpy(desc_in%halo_index,desc_out%halo_index,info) +!!$ if (info == 0) call psb_safe_cpy(desc_in%halo_pt,desc_out%halo_pt,info) + if (info == 0) call psb_safe_cpy(desc_in%ovrlap_index,desc_out%ovrlap_index,info) +!!$ if (info == 0) call psb_safe_cpy(desc_in%ovrlap_pt,desc_out%ovrlap_pt,info) + if (info == 0) call psb_safe_cpy(desc_in%bnd_elem,desc_out%bnd_elem,info) + if (info == 0) call psb_safe_cpy(desc_in%ovrlap_elem,desc_out%ovrlap_elem,info) + if (info == 0) call psb_safe_cpy(desc_in%loc_to_glob,desc_out%loc_to_glob,info) + if (info == 0) call psb_safe_cpy(desc_in%glob_to_loc,desc_out%glob_to_loc,info) + if (info == 0) call psb_safe_cpy(desc_in%lprm,desc_out%lprm,info) + if (info == 0) call psb_safe_cpy(desc_in%idx_space,desc_out%idx_space,info) - if (associated(desc_in%bnd_elem)) then - isz = size(desc_in%bnd_elem) - ! allocate(desc_out%matrix_data(isz),stat=info) - call psb_realloc(isz,desc_out%bnd_elem,info) - if(debugprt) write(0,*) 'cdcpy: bnd_elem',isz,':',desc_in%bnd_elem(:) - if (info /= 0) then - info=4010 - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - desc_out%bnd_elem(:) = desc_in%bnd_elem(:) - endif + if (info /= 0) then + info = 4010 + call psb_errpush(info,name) + goto 9999 endif - if (debug) write(0,*) me,'Done bnd_elem' - if (associated(desc_in%ovrlap_elem)) then - isz = size(desc_in%ovrlap_elem) - ! allocate(desc_out%matrix_data(isz),stat=info) - call psb_realloc(isz,desc_out%ovrlap_elem,info) - if(debugprt) write(0,*) 'cdcpy: ovrlap_elem',isz,':',desc_in%ovrlap_elem(:) - if (info /= 0) then - info=4010 - char_err='psrealloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - desc_out%ovrlap_elem(:) = desc_in%ovrlap_elem(:) - endif - endif - if (debug) write(0,*) me,'Done ovrlap_elem' - - if (associated(desc_in%ovrlap_index)) then - isz = size(desc_in%ovrlap_index) - ! allocate(desc_out%matrix_data(isz),stat=info) - call psb_realloc(isz,desc_out%ovrlap_index,info) - if(debugprt) write(0,*) 'cdcpy: ovrlap_index',isz,':',desc_in%ovrlap_index(:) - if (info /= 0) then - info=4010 - char_err='psrealloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - desc_out%ovrlap_index(:) = desc_in%ovrlap_index(:) - endif - endif - if (debug) write(0,*) me,'Done ovrlap_index' - - if (associated(desc_in%loc_to_glob)) then - isz = size(desc_in%loc_to_glob) - ! allocate(desc_out%matrix_data(isz),stat=info) - call psb_realloc(isz,desc_out%loc_to_glob,info) - if(debugprt) write(0,*) 'cdcpy: loc_to_glob',isz,':',desc_in%loc_to_glob(:) - if (info /= 0) then - info=4010 - char_err='psrealloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - desc_out%loc_to_glob(:) = desc_in%loc_to_glob(:) - endif - endif - if (debug) write(0,*) me,'Done loc_to_glob' - - if (associated(desc_in%glob_to_loc)) then - isz = size(desc_in%glob_to_loc) - ! allocate(desc_out%matrix_data(isz),stat=info) - call psb_realloc(isz,desc_out%glob_to_loc,info) - if(debugprt) write(0,*) 'cdcpy: glob_to_loc',isz,':',desc_in%glob_to_loc(:) - if (info /= 0) then - info=4010 - char_err='psrealloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - desc_out%glob_to_loc(:) = desc_in%glob_to_loc(:) - endif - endif - if (debug) write(0,*) me,'Done glob_to_loc' - - if (associated(desc_in%lprm)) then - isz = size(desc_in%lprm) - ! allocate(desc_out%matrix_data(isz),stat=info) - call psb_realloc(isz,desc_out%lprm,info) - if(debugprt) write(0,*) 'cdcpy: lprm',isz,':',desc_in%lprm(:) - if (info /= 0) then - info=4010 - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - desc_out%lprm(:) = desc_in%lprm(:) - endif - endif - if (debug) write(0,*) me,'Done lprm' - - if (associated(desc_in%idx_space)) then - isz = size(desc_in%idx_space) - ! allocate(desc_out%matrix_data(isz),stat=info) - call psb_realloc(isz,desc_out%idx_space,info) - if(debugprt) write(0,*) 'cdcpy: idx_space',isz,':',desc_in%idx_space(:) - if (info /= 0) then - info=4010 - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - desc_out%idx_space(:) = desc_in%idx_space(:) - endif - endif - call psb_erractionrestore(err_act) return diff --git a/src/tools/psb_cddec.f90 b/src/tools/psb_cddec.f90 index 72af03118..fc8477734 100644 --- a/src/tools/psb_cddec.f90 +++ b/src/tools/psb_cddec.f90 @@ -107,6 +107,7 @@ subroutine psb_cddec(nloc, ictxt, desc_a, info) use psb_serial_mod use psb_const_mod use psb_error_mod + use psi_mod use psb_penv_mod implicit None !....Parameters... @@ -117,7 +118,7 @@ subroutine psb_cddec(nloc, ictxt, desc_a, info) !locals Integer :: i,j,np,me,err,n,itmpov, k,& & l_ov_ix,l_ov_el,idx, err_act,m, ip - Integer :: INT_ERR(5) + Integer :: INT_ERR(5), thalo(1), tovr(1) integer, allocatable :: nlv(:) logical, parameter :: debug=.false. character(len=20) :: name @@ -164,10 +165,12 @@ subroutine psb_cddec(nloc, ictxt, desc_a, info) !count local rows number ! allocate work vector +!!$ allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(psb_mdata_size_),& +!!$ & desc_a%loc_to_glob(nloc),desc_a%lprm(1),& +!!$ & desc_a%ovrlap_index(1),desc_a%ovrlap_elem(1),& +!!$ & desc_a%halo_index(1),desc_a%bnd_elem(1),stat=info) allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(psb_mdata_size_),& - & desc_a%loc_to_glob(nloc),desc_a%lprm(1),& - & desc_a%ovrlap_index(1),desc_a%ovrlap_elem(1),& - & desc_a%halo_index(1),desc_a%bnd_elem(1),stat=info) + & desc_a%loc_to_glob(m),desc_a%lprm(1),stat=info) if (info /= 0) then info=2025 int_err(1)=m @@ -175,7 +178,13 @@ subroutine psb_cddec(nloc, ictxt, desc_a, info) goto 9999 endif - + desc_a%matrix_data(psb_m_) = m + desc_a%matrix_data(psb_n_) = m + desc_a%matrix_data(psb_n_row_) = nloc + desc_a%matrix_data(psb_n_col_) = nloc + desc_a%matrix_data(psb_dec_type_) = psb_desc_bld_ + desc_a%matrix_data(psb_ctxt_) = ictxt + call psb_get_mpicomm(ictxt,desc_a%matrix_data(psb_mpi_c_)) j = 1 do ip=0, np-1 @@ -194,21 +203,18 @@ subroutine psb_cddec(nloc, ictxt, desc_a, info) enddo - + tovr = -1 + thalo = -1 + desc_a%lprm(:) = 0 - desc_a%halo_index(:) = -1 - desc_a%bnd_elem(:) = -1 - desc_a%ovrlap_index(:) = -1 - desc_a%ovrlap_elem(:) = -1 + call psi_cnv_dsc(thalo,tovr,desc_a,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psi_bld_cdesc') + goto 9999 + end if - desc_a%matrix_data(psb_m_) = m - desc_a%matrix_data(psb_n_) = m - desc_a%matrix_data(psb_n_row_) = nloc - desc_a%matrix_data(psb_n_col_) = nloc desc_a%matrix_data(psb_dec_type_) = psb_desc_asb_ - desc_a%matrix_data(psb_ctxt_) = ictxt - call psb_get_mpicomm(ictxt,desc_a%matrix_data(psb_mpi_c_)) call psb_erractionrestore(err_act) return diff --git a/src/tools/psb_cdfree.f90 b/src/tools/psb_cdfree.f90 index 1e68664f4..ce1501d69 100644 --- a/src/tools/psb_cdfree.f90 +++ b/src/tools/psb_cdfree.f90 @@ -159,6 +159,34 @@ subroutine psb_cdfree(desc_a,info) goto 9999 end if + if (associated(desc_a%idx_space)) then + deallocate(desc_a%idx_space,stat=info) + if (info /= 0) then + info=2056 + call psb_errpush(info,name) + goto 9999 + end if + end if + +!!$ if (associated(desc_a%halo_pt)) then +!!$ deallocate(desc_a%halo_pt,stat=info) +!!$ if (info /= 0) then +!!$ info=2056 +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ end if +!!$ end if +!!$ +!!$ if (associated(desc_a%ovrlap_pt)) then +!!$ deallocate(desc_a%ovrlap_pt,stat=info) +!!$ if (info /= 0) then +!!$ info=2056 +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ end if +!!$ end if + + call psb_nullify_desc(desc_a) call psb_erractionrestore(err_act) diff --git a/src/tools/psb_cdprt.f90 b/src/tools/psb_cdprt.f90 index 742ba5409..2d14eef3f 100644 --- a/src/tools/psb_cdprt.f90 +++ b/src/tools/psb_cdprt.f90 @@ -62,7 +62,7 @@ subroutine psb_cdprt(iout,desc_p,glob,short) endif if (.not.lglob) then - write(iout,*) 'Precond. descriptor:',desc_p%matrix_data(1:10) + write(iout,*) 'Communication descriptor:',desc_p%matrix_data(1:10) m=desc_p%matrix_data(psb_m_) n_row=desc_p%matrix_data(psb_n_row_) n_col=desc_p%matrix_data(psb_n_col_) @@ -121,7 +121,7 @@ subroutine psb_cdprt(iout,desc_p,glob,short) else if (lglob) then - write(iout,*) 'Precond. descriptor:',desc_p%matrix_data(1:10) + write(iout,*) 'Communication descriptor:',desc_p%matrix_data(1:10) m=desc_p%matrix_data(psb_m_) n_row=desc_p%matrix_data(psb_n_row_) n_col=desc_p%matrix_data(psb_n_col_) diff --git a/src/tools/psb_cdrep.f90 b/src/tools/psb_cdrep.f90 index c3d37de9d..654611526 100644 --- a/src/tools/psb_cdrep.f90 +++ b/src/tools/psb_cdrep.f90 @@ -107,6 +107,7 @@ subroutine psb_cdrep(m, ictxt, desc_a, info) use psb_serial_mod use psb_const_mod use psb_error_mod + use psi_mod use psb_penv_mod implicit None !....Parameters... @@ -116,7 +117,7 @@ subroutine psb_cdrep(m, ictxt, desc_a, info) !locals Integer :: i,np,me,err,n,err_act - integer :: int_err(5),exch(2) + integer :: int_err(5),exch(2), thalo(1), tovr(1) logical, parameter :: debug=.false. character(len=20) :: name @@ -174,9 +175,9 @@ subroutine psb_cdrep(m, ictxt, desc_a, info) !count local rows number ! allocate work vector allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(psb_mdata_size_),& - & desc_a%loc_to_glob(m),desc_a%lprm(1),& - & desc_a%ovrlap_index(1),desc_a%ovrlap_elem(1),& - & desc_a%halo_index(1),desc_a%bnd_elem(1),stat=info) + & desc_a%loc_to_glob(m),desc_a%lprm(1),stat=info) +!!$ & desc_a%ovrlap_index(1),desc_a%ovrlap_elem(1),& +!!$ & desc_a%halo_index(1),desc_a%bnd_elem(1),stat=info) if (info /= 0) then info=2025 int_err(1)=m @@ -184,25 +185,32 @@ subroutine psb_cdrep(m, ictxt, desc_a, info) goto 9999 endif + + desc_a%matrix_data(psb_m_) = m + desc_a%matrix_data(psb_n_) = n + desc_a%matrix_data(psb_n_row_) = m + desc_a%matrix_data(psb_n_col_) = n + desc_a%matrix_data(psb_dec_type_) = psb_desc_bld_ + desc_a%matrix_data(psb_ctxt_) = ictxt + call psb_get_mpicomm(ictxt,desc_a%matrix_data(psb_mpi_c_)) do i=1,m desc_a%glob_to_loc(i) = i desc_a%loc_to_glob(i) = i enddo - desc_a%lprm(:) = 0 - desc_a%halo_index(:) = -1 - desc_a%bnd_elem(:) = -1 - desc_a%ovrlap_index(:) = -1 - desc_a%ovrlap_elem(:) = -1 - desc_a%matrix_data(psb_m_) = m - desc_a%matrix_data(psb_n_) = n - desc_a%matrix_data(psb_n_row_) = m - desc_a%matrix_data(psb_n_col_) = n + tovr = -1 + thalo = -1 + desc_a%lprm(:) = 0 + + call psi_cnv_dsc(thalo,tovr,desc_a,info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='psi_bld_cdesc') + goto 9999 + end if + desc_a%matrix_data(psb_dec_type_) = psb_desc_repl_ - desc_a%matrix_data(psb_ctxt_) = ictxt - call psb_get_mpicomm(ictxt,desc_a%matrix_data(psb_mpi_c_)) call psb_erractionrestore(err_act) return diff --git a/src/tools/psb_dcdovr.f90 b/src/tools/psb_dcdovr.f90 index 7dac2af85..681ced1b1 100644 --- a/src/tools/psb_dcdovr.f90 +++ b/src/tools/psb_dcdovr.f90 @@ -170,10 +170,9 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) index_dim = size(desc_a%halo_index) elem_dim = size(desc_a%halo_index) - allocate(desc_ov%ovrlap_index(novr*(Max(2*index_dim,1)+1)),& - & desc_ov%ovrlap_elem(novr*(Max(elem_dim,1)+3)),& - & desc_ov%matrix_data(psb_mdata_size_),& - & desc_ov%halo_index(novr*(Size(desc_a%halo_index)+3)),STAT=INFO) + nullify(desc_ov%ovrlap_index,desc_ov%halo_index,desc_ov%ovrlap_elem) + allocate(desc_ov%ovrlap_elem(novr*(Max(elem_dim,1)+3)),& + & desc_ov%matrix_data(psb_mdata_size_),STAT=INFO) if (info /= 0) then info=4000 call psb_errpush(info,name) @@ -183,10 +182,7 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) l_tmp_ovr_idx=novr*(3*Max(2*index_dim,1)+1) l_tmp_halo=novr*(3*Size(desc_a%halo_index)) - desc_ov%ovrlap_index(:) = -1 - desc_ov%ovrlap_elem(:) = -1 - desc_ov%halo_index(:) = -1 - desc_ov%matrix_data(1:10) = desc_a%matrix_data(1:10) + desc_ov%matrix_data(:) = desc_a%matrix_data(:) desc_ov%matrix_data(psb_dec_type_) = psb_desc_bld_ Allocate(desc_ov%loc_to_glob(Size(desc_a%loc_to_glob)),& @@ -203,11 +199,13 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info) Write(0,*)'Start cdovrbld',me,lworks,lworkr call psb_barrier(ictxt) endif + ! ! The real work goes on in here.... ! Call psb_cdovrbld(novr,desc_ov,desc_a,a,& & l_tmp_halo,l_tmp_ovr_idx,lworks,lworkr,info) + if (info /= 0) then info=4010 ch_err='psb_cdovrbld' diff --git a/src/tools/psb_dcdovrbld.f90 b/src/tools/psb_dcdovrbld.f90 index fde756e2d..217a7d11f 100644 --- a/src/tools/psb_dcdovrbld.f90 +++ b/src/tools/psb_dcdovrbld.f90 @@ -38,14 +38,16 @@ ! ! Parameters: ! n_ovr - integer. The number of overlap levels -! desc_p - type(). The communication descriptor for the preconditioner. +! desc_p - type(). The communication descriptor +! for the preconditioner. ! desc_a - type(). The communication descriptor. -! a - type(Size(halo)) then + + If ((counter+psb_elem_recv_+j)>Size(halo)) then info=-2 call psb_errpush(info,name) goto 9999 @@ -292,34 +275,6 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,& counter_h=counter_h+3 - call SearchInsKeyVal(pairtree,gidx,counter_e,glx,info) -!!$ if (debug) write(0,*) 'From searchInsKey ',gidx,glx,counter_e,info - if (info>=0) then - If (glx < counter_e) Then - desc_p%ovrlap_elem(glx+psb_n_dom_ovr_)= & - & desc_p%ovrlap_elem(glx+psb_n_dom_ovr_)+1 - Else - If((counter_e+2) > Size(desc_p%ovrlap_elem)) Then - isz = max((3*Size(desc_p%ovrlap_elem))/2,(counter_e+3)) - if (debug) write(0,*) me,'Realloc ovr_El',isz - call psb_realloc(isz,desc_p%ovrlap_elem,info) - if (info /= 0) then - info=4010 - ch_err='psrealloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - End If -!!$ if (debug) write(0,*) 'Adding into ovrlap ',gidx,glx,counter_e,info - - desc_p%ovrlap_elem(counter_e)=gidx - desc_p%ovrlap_elem(counter_e+psb_n_dom_ovr_)=2 - desc_p%ovrlap_elem(counter_e+2)=-1 - counter_e = counter_e + 2 - End If - else - write(0,*) me, 'Cdovrbld From SearchInsKeyVal: ',info - endif Enddo if (debug) write(0,*) me,'Checktmp_o_i Loop Mid1',tmp_ovr_idx(1:10) counter = counter+n_elem_recv @@ -350,34 +305,6 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,& tmp_ovr_idx(counter_o+3)=-1 counter_o=counter_o+3 - call SearchInsKeyVal(pairtree,gidx,counter_e,glx,info) -!!$ if (debug) write(0,*) 'From searchInsKey ',gidx,glx,counter_e,info - if (info>=0) then - If (glx < counter_e) Then - desc_p%ovrlap_elem(glx+psb_n_dom_ovr_)= & - & desc_p%ovrlap_elem(glx+psb_n_dom_ovr_)+1 - Else - If((counter_e+2) > Size(desc_p%ovrlap_elem)) Then - isz = max((3*Size(desc_p%ovrlap_elem))/2,(counter_e+3)) - if (debug) write(0,*) me,'Realloc ovr_el',isz - call psb_realloc(isz,desc_p%ovrlap_elem,info) - if (info /= 0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - End If -!!$ if (debug) write(0,*) 'Adding into ovrlap ',gidx,glx,counter_e,info - desc_p%ovrlap_elem(counter_e)=gidx - desc_p%ovrlap_elem(counter_e+psb_n_dom_ovr_)=2 - desc_p%ovrlap_elem(counter_e+2)=-1 - counter_e = counter_e + 2 - End If - else - write(0,*) me,'Cdovrbld From SearchInsKeyVal: ',info - endif - ! ! Prepare to exchange the halo rows with the other proc. ! @@ -402,6 +329,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,& end if lworks = isz End If + If((n_elem) > size(blk%ia2)) Then isz = max((3*size(blk%ia2))/2,(n_elem)) if (debug) write(0,*) me,'Realloc blk',isz @@ -434,18 +362,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,& if (i_ovr < n_ovr) then if (tot_elem > 1) then -!!$ write(0,*) me,'Realloc temp',tot_elem+2 - if (tot_elem+2 > size(temp)) then -!!$ write(0,*) me,'Realloc temp',tot_elem+2 - deallocate(temp) - allocate(temp(tot_elem+2),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - endif - Call mrgsrt(tot_elem,works(idxs+1),temp,info) - If (info == 0) Call ireordv1(tot_elem,works(idxs+1),temp) + call imsr(tot_elem,works(idxs+1)) lx = works(idxs+1) i = 1 j = 1 @@ -546,7 +463,18 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,& End If desc_p%glob_to_loc(idx)=n_col desc_p%loc_to_glob(n_col)=idx - If((counter_t+3) > Size(t_halo_in))Write(0,*)'bingo' + If ((counter_t+3) > Size(t_halo_in)) then + isz = max((3*Size(t_halo_in))/2,(counter_t+3+1000)) + if (debug) write(0,*) me,'Realloc ovr_el',isz + call psb_realloc(isz,t_halo_in,info) + if (info /= 0) then + info=4010 + ch_err='psrealloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end If + t_halo_in(counter_t)=proc_id t_halo_in(counter_t+1)=1 t_halo_in(counter_t+2)=n_col @@ -591,7 +519,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,& if (debug) write(0,*) me,'Checktmp_o_i 1',tmp_ovr_idx(1:10) if (debug) write(0,*) me,'Calling Crea_Halo' - call psi_crea_index(desc_p,t_halo_in,t_halo_out,.false.,info) + call psi_crea_index(desc_p,t_halo_in,t_halo_out,.false.,nxch,nsnd,nrcv,info) if (debug) then write(0,*) me,'Done Crea_Index' @@ -611,7 +539,6 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,& tch = tch +(t3-t2) End Do t1 = mpi_wtime() - call FreePairSearchTree(pairtree) desc_p%matrix_data(psb_m_)=desc_a%matrix_data(psb_m_) desc_p%matrix_data(psb_n_)=desc_a%matrix_data(psb_n_) @@ -627,35 +554,12 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,& ! if (debug) then - write(0,*) 'psb_cdasb: converting indexes' + write(0,*) 'psb_cdovrbld: converting indexes' call psb_barrier(ictxt) end if !.... convert comunication stuctures.... - ! first the halo index - call psi_crea_index(desc_p,tmp_halo,& - & desc_p%halo_index,.false.,info) - if(info /= 0) then - call psb_errpush(4010,name,a_err='psi_crea_index') - goto 9999 - end if - - ! then the overlap index - call psi_crea_index(desc_p,tmp_ovr_idx,& - & desc_p%ovrlap_index,.true.,info) - if(info /= 0) then - call psb_errpush(4010,name,a_err='psi_crea_index') - goto 9999 - end if - ! next is the ovrlap_elem index - call psi_crea_ovr_elem(desc_p%ovrlap_index,desc_p%ovrlap_elem) - - ! finally bnd_elem - call psi_crea_bnd_elem(desc_p,info) - if(info /= 0) then - call psb_errpush(4010,name,a_err='psi_crea_bnd_elem') - goto 9999 - end if + call psi_cnv_dsc(tmp_halo,tmp_ovr_idx,desc_p,info) ! Ok, register into MATRIX_DATA & free temporary work areas desc_p%matrix_data(psb_dec_type_) = psb_desc_asb_ diff --git a/src/tools/psb_dsphalo.f90 b/src/tools/psb_dsphalo.f90 index 2bb50970f..eb17f63eb 100644 --- a/src/tools/psb_dsphalo.f90 +++ b/src/tools/psb_dsphalo.f90 @@ -54,10 +54,9 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) use psb_tools_mod, only : psb_glob_to_loc, psb_loc_to_glob use psb_error_mod use psb_penv_mod - + use mpi Implicit None - include 'mpif.h' Type(psb_dspmat_type),Intent(in) :: a Type(psb_dspmat_type),Intent(inout) :: blk Type(psb_desc_type),Intent(in) :: desc_a diff --git a/src/tools/psb_zcdovr.f90 b/src/tools/psb_zcdovr.f90 index 19da5edbd..01c339c68 100644 --- a/src/tools/psb_zcdovr.f90 +++ b/src/tools/psb_zcdovr.f90 @@ -91,7 +91,8 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) ! .. Local Scalars .. - Integer :: np, me,m,nnzero, ictxt, lovr, lworks,lworkr, n_col, int_err(5),& + Integer :: i, j, k, np, me,m,nnzero,& + & ictxt, lovr, lworks,lworkr, n_col, int_err(5),& & index_dim,elem_dim, l_tmp_ovr_idx,l_tmp_halo, nztot,nhalo Logical, parameter :: debug=.false. character(len=20) :: name, ch_err @@ -144,7 +145,6 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) t1 = mpi_wtime() - ! ! Ok, since we are only estimating, do it as follows: ! LOVR= (NNZ/NROW)*N_HALO*N_OVR This assumes that the local average @@ -170,10 +170,9 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) index_dim = size(desc_a%halo_index) elem_dim = size(desc_a%halo_index) - allocate(desc_ov%ovrlap_index(novr*(Max(2*index_dim,1)+1)),& - & desc_ov%ovrlap_elem(novr*(Max(elem_dim,1)+3)),& - & desc_ov%matrix_data(psb_mdata_size_),& - & desc_ov%halo_index(novr*(Size(desc_a%halo_index)+3)),STAT=INFO) + nullify(desc_ov%ovrlap_index,desc_ov%halo_index,desc_ov%ovrlap_elem) + allocate(desc_ov%ovrlap_elem(novr*(Max(elem_dim,1)+3)),& + & desc_ov%matrix_data(psb_mdata_size_),STAT=INFO) if (info /= 0) then info=4000 call psb_errpush(info,name) @@ -183,10 +182,7 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info) l_tmp_ovr_idx=novr*(3*Max(2*index_dim,1)+1) l_tmp_halo=novr*(3*Size(desc_a%halo_index)) - desc_ov%ovrlap_index(:) = -1 - desc_ov%ovrlap_elem(:) = -1 - desc_ov%halo_index(:) = -1 - desc_ov%matrix_data(1:10) = desc_a%matrix_data(1:10) + desc_ov%matrix_data(:) = desc_a%matrix_data(:) desc_ov%matrix_data(psb_dec_type_) = psb_desc_bld_ Allocate(desc_ov%loc_to_glob(Size(desc_a%loc_to_glob)),& diff --git a/src/tools/psb_zcdovrbld.f90 b/src/tools/psb_zcdovrbld.f90 index 3835271c9..e62b3997d 100644 --- a/src/tools/psb_zcdovrbld.f90 +++ b/src/tools/psb_zcdovrbld.f90 @@ -37,15 +37,17 @@ ! Note that n_ovr > 0 thanks to the caller routine. ! ! Parameters: -! n_ovr - integer. The number of overlap levels -! desc_p - type(). The communication descriptor for the preconditioner. +! n_ovr - integer. The number of overlap levels +! desc_p - type(). The communication descriptor +! for the preconditioner. ! desc_a - type(). The communication descriptor. -! a - type(Size(halo)) then + + If ((counter+psb_elem_recv_+j)>Size(halo)) then info=-2 call psb_errpush(info,name) goto 9999 @@ -292,34 +274,6 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,& counter_h=counter_h+3 - call SearchInsKeyVal(pairtree,gidx,counter_e,glx,info) -!!$ if (debug) write(0,*) 'From searchInsKey ',gidx,glx,counter_e,info - if (info>=0) then - If (glx < counter_e) Then - desc_p%ovrlap_elem(glx+psb_n_dom_ovr_)= & - & desc_p%ovrlap_elem(glx+psb_n_dom_ovr_)+1 - Else - If((counter_e+2) > Size(desc_p%ovrlap_elem)) Then - isz = max((3*Size(desc_p%ovrlap_elem))/2,(counter_e+3)) - if (debug) write(0,*) me,'Realloc ovr_El',isz - call psb_realloc(isz,desc_p%ovrlap_elem,info) - if (info /= 0) then - info=4010 - ch_err='psrealloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - End If -!!$ if (debug) write(0,*) 'Adding into ovrlap ',gidx,glx,counter_e,info - - desc_p%ovrlap_elem(counter_e)=gidx - desc_p%ovrlap_elem(counter_e+psb_n_dom_ovr_)=2 - desc_p%ovrlap_elem(counter_e+2)=-1 - counter_e = counter_e + 2 - End If - else - write(0,*) me, 'Cdovrbld From SearchInsKeyVal: ',info - endif Enddo if (debug) write(0,*) me,'Checktmp_o_i Loop Mid1',tmp_ovr_idx(1:10) counter = counter+n_elem_recv @@ -350,34 +304,6 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,& tmp_ovr_idx(counter_o+3)=-1 counter_o=counter_o+3 - call SearchInsKeyVal(pairtree,gidx,counter_e,glx,info) -!!$ if (debug) write(0,*) 'From searchInsKey ',gidx,glx,counter_e,info - if (info>=0) then - If (glx < counter_e) Then - desc_p%ovrlap_elem(glx+psb_n_dom_ovr_)= & - & desc_p%ovrlap_elem(glx+psb_n_dom_ovr_)+1 - Else - If((counter_e+2) > Size(desc_p%ovrlap_elem)) Then - isz = max((3*Size(desc_p%ovrlap_elem))/2,(counter_e+3)) - if (debug) write(0,*) me,'Realloc ovr_el',isz - call psb_realloc(isz,desc_p%ovrlap_elem,info) - if (info /= 0) then - info=4010 - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - End If -!!$ if (debug) write(0,*) 'Adding into ovrlap ',gidx,glx,counter_e,info - desc_p%ovrlap_elem(counter_e)=gidx - desc_p%ovrlap_elem(counter_e+psb_n_dom_ovr_)=2 - desc_p%ovrlap_elem(counter_e+2)=-1 - counter_e = counter_e + 2 - End If - else - write(0,*) me,'Cdovrbld From SearchInsKeyVal: ',info - endif - ! ! Prepare to exchange the halo rows with the other proc. ! @@ -402,6 +328,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,& end if lworks = isz End If + If((n_elem) > size(blk%ia2)) Then isz = max((3*size(blk%ia2))/2,(n_elem)) if (debug) write(0,*) me,'Realloc blk',isz @@ -434,18 +361,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,& if (i_ovr < n_ovr) then if (tot_elem > 1) then -!!$ write(0,*) me,'Realloc temp',tot_elem+2 - if (tot_elem+2 > size(temp)) then -!!$ write(0,*) me,'Realloc temp',tot_elem+2 - deallocate(temp) - allocate(temp(tot_elem+2),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - endif - Call mrgsrt(tot_elem,works(idxs+1),temp,info) - If (info == 0) Call ireordv1(tot_elem,works(idxs+1),temp) + call imsr(tot_elem,works(idxs+1)) lx = works(idxs+1) i = 1 j = 1 @@ -546,7 +462,18 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,& End If desc_p%glob_to_loc(idx)=n_col desc_p%loc_to_glob(n_col)=idx - If((counter_t+3) > Size(t_halo_in))Write(0,*)'bingo' + If ((counter_t+3) > Size(t_halo_in)) then + isz = max((3*Size(t_halo_in))/2,(counter_t+3+1000)) + if (debug) write(0,*) me,'Realloc ovr_el',isz + call psb_realloc(isz,t_halo_in,info) + if (info /= 0) then + info=4010 + ch_err='psrealloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end If + t_halo_in(counter_t)=proc_id t_halo_in(counter_t+1)=1 t_halo_in(counter_t+2)=n_col @@ -591,7 +518,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,& if (debug) write(0,*) me,'Checktmp_o_i 1',tmp_ovr_idx(1:10) if (debug) write(0,*) me,'Calling Crea_Halo' - call psi_crea_index(desc_p,t_halo_in,t_halo_out,.false.,info) + call psi_crea_index(desc_p,t_halo_in,t_halo_out,.false.,nxch,nsnd,nrcv,info) if (debug) then write(0,*) me,'Done Crea_Index' @@ -611,7 +538,6 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,& tch = tch +(t3-t2) End Do t1 = mpi_wtime() - call FreePairSearchTree(pairtree) desc_p%matrix_data(psb_m_)=desc_a%matrix_data(psb_m_) desc_p%matrix_data(psb_n_)=desc_a%matrix_data(psb_n_) @@ -627,35 +553,12 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,& ! if (debug) then - write(0,*) 'psb_cdasb: converting indexes' + write(0,*) 'psb_cdovrbld: converting indexes' call psb_barrier(ictxt) end if !.... convert comunication stuctures.... - ! first the halo index - call psi_crea_index(desc_p,tmp_halo,& - & desc_p%halo_index,.false.,info) - if(info /= 0) then - call psb_errpush(4010,name,a_err='psi_crea_index') - goto 9999 - end if - - ! then the overlap index - call psi_crea_index(desc_p,tmp_ovr_idx,& - & desc_p%ovrlap_index,.true.,info) - if(info /= 0) then - call psb_errpush(4010,name,a_err='psi_crea_index') - goto 9999 - end if - ! next is the ovrlap_elem index - call psi_crea_ovr_elem(desc_p%ovrlap_index,desc_p%ovrlap_elem) - - ! finally bnd_elem - call psi_crea_bnd_elem(desc_p,info) - if(info /= 0) then - call psb_errpush(4010,name,a_err='psi_crea_bnd_elem') - goto 9999 - end if + call psi_cnv_dsc(tmp_halo,tmp_ovr_idx,desc_p,info) ! Ok, register into MATRIX_DATA & free temporary work areas desc_p%matrix_data(psb_dec_type_) = psb_desc_asb_ diff --git a/src/tools/psb_zsphalo.f90 b/src/tools/psb_zsphalo.f90 index 221b25ab3..07dde70fb 100644 --- a/src/tools/psb_zsphalo.f90 +++ b/src/tools/psb_zsphalo.f90 @@ -54,10 +54,9 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rwcnv,clcnv,outfmt) use psb_tools_mod, only : psb_glob_to_loc, psb_loc_to_glob use psb_error_mod use psb_penv_mod - + use mpi Implicit None - include 'mpif.h' Type(psb_zspmat_type),Intent(in) :: a Type(psb_zspmat_type),Intent(inout) :: blk Type(psb_desc_type),Intent(in) :: desc_a