F_VOID_FUNC igebs2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n, int *A, int *lda) #endif /* * -- V1.1 BLACS routine -- * University of Tennessee, May 1, 1996 * Written by Clint Whaley. * * Purpose * ======= * Broadcast/send for general integer arrays. * * Arguments * ========= * * ConTxt (input) Ptr to int * Index into MyConTxts00 (my contexts array). * * SCOPE (input) Ptr to char * Limit the scope of the operation. * = 'R' : Operation is performed by a process row. * = 'C' : Operation is performed by a process column. * = 'A' : Operation is performed by all processes in grid. * * TOP (input) Ptr to char * Controls fashion in which messages flow within the operation. * * M (input) Ptr to int * The number of rows of the matrix A. M >= 0. * * N (input) Ptr to int * The number of columns of the matrix A. N >= 0. * * A (input) Ptr to integer two dimensional array * The m by n matrix A. Fortran77 (column-major) storage * assumed. * * LDA (input) Ptr to int * The leading dimension of the array A. LDA >= M. * * ------------------------------------------------------------------------ */ { void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int, int *, int *); int BI_HypBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR); void BI_IdringBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int); void BI_SringBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR); void BI_MpathBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int); void BI_TreeBS(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int); void BI_UpdateBuffs(BLACBUFF *); BLACBUFF *BI_GetBuff(int); int BI_BuffIsFree(BLACBUFF *, int); MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int, MPI_Datatype, int *); BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype); void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *); void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *); char ttop, tscope; int error, tlda; MPI_Datatype MatTyp; SDRVPTR send; BLACBUFF *bp; BLACSCONTEXT *ctxt; extern BLACBUFF BI_AuxBuff, *BI_ActiveQ; /* * get context, lowcase char variables, and perform parameter checking */ MGetConTxt(Mpval(ConTxt), ctxt); ttop = F2C_CharTrans(top); ttop = Mlowcase(ttop); tscope = F2C_CharTrans(scope); tscope = Mlowcase(tscope); #if (BlacsDebugLvl > 0) BI_ArgCheck(Mpval(ConTxt), RT_BS, __FILE__, 'a', 'u', 'u', Mpval(m), Mpval(n), Mpval(lda), 0, NULL, NULL); #endif /* * If the user has set the default broadcast topology, use it instead of * BLACS default */ #ifdef DefBSTop if (ttop == ' ') ttop = DefBSTop; #endif if (Mpval(lda) < Mpval(m)) tlda = Mpval(m); else tlda = Mpval(lda); switch(tscope) { case 'r': ctxt->scp = &ctxt->rscp; break; case 'c': ctxt->scp = &ctxt->cscp; break; case 'a': ctxt->scp = &ctxt->ascp; break; default: BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'", tscope); } MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda, MPI_INT, &BI_AuxBuff.N); /* * If using default topology, use MPI native broadcast */ if (ttop == ' ') { error=MPI_Bcast(A, BI_AuxBuff.N, MatTyp, ctxt->scp->Iam, ctxt->scp->comm); error=MPI_Type_free(&MatTyp); if (BI_ActiveQ) BI_UpdateBuffs(NULL); return; } /* * If MPI handles non-contiguous buffering well, always use MPI data types * instead of packing */ #ifndef MpiBuffGood /* * If A is contiguous, send directly from it */ else if ( (tlda == Mpval(m)) || (Mpval(n) == 1) ) { #endif send = BI_Ssend; BI_AuxBuff.Buff = (char *) A; BI_AuxBuff.dtype = MatTyp; bp = &BI_AuxBuff; #ifndef MpiBuffGood } else { send = BI_Asend; bp = BI_Pack(ctxt, (BVOID *) A, NULL, MatTyp); } #endif /* * Call correct topology for BS/BR */ switch(ttop) { case 'h': error = BI_HypBS(ctxt, bp, send); if (error == NPOW2) BI_TreeBS(ctxt, bp, send, 2); break; case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': BI_TreeBS(ctxt, bp, send, ttop-47); break; case 't': BI_TreeBS(ctxt, bp, send, ctxt->Nb_bs); break; case 'i': BI_IdringBS(ctxt, bp, send, 1); break; case 'd': BI_IdringBS(ctxt, bp, send, -1); break; case 's': BI_SringBS(ctxt, bp, send); break; case 'f': BI_MpathBS(ctxt, bp, send, FULLCON); break; case 'm': BI_MpathBS(ctxt, bp, send, ctxt->Nr_bs); break; default : BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",ttop); } error=MPI_Type_free(&MatTyp); if (bp == &BI_AuxBuff) { if (BI_ActiveQ) BI_UpdateBuffs(NULL); } else BI_UpdateBuffs(bp); } /* end igebs2d_ */
F_VOID_FUNC sgerv2d_(int *ConTxt, int *m, int *n, float *A, int *lda, int *rsrc, int *csrc) #endif /* * -- V1.1 BLACS routine -- * University of Tennessee, May 1, 1996 * Written by Clint Whaley. * * Purpose * ======= * Globally-blocking point to point general real receive. * * Arguments * ========= * * ConTxt (input) Ptr to int * Index into MyConTxts00 (my contexts array). * * M (input) Ptr to int * The number of rows of the matrix A. M >= 0. * * N (input) Ptr to int * The number of columns of the matrix A. N >= 0. * * A (output) Ptr to real two dimensional array * The m by n matrix A. Fortran77 (column-major) storage * assumed. * * LDA (input) Ptr to int * The leading dimension of the array A. LDA >= M. * * * RSRC (input) Ptr to int * The process row of the source of the matrix. * * CSRC (input) Ptr to int * The process column of the source of the matrix. * * * ------------------------------------------------------------------------ */ { /* * Prototypes and variable declarations */ void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int, int *, int *); MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int, MPI_Datatype, int *); void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype); void BI_Srecv(BLACSCONTEXT *, int, int, BLACBUFF *); void BI_UpdateBuffs(BLACBUFF *); BLACBUFF *BI_GetBuff(int); int BI_BuffIsFree(BLACBUFF *, int); int tlda; int ierr; MPI_Datatype MatTyp; BLACSCONTEXT *ctxt; extern BLACBUFF BI_AuxBuff, *BI_ActiveQ; MGetConTxt(Mpval(ConTxt), ctxt); #if (BlacsDebugLvl > 0) BI_ArgCheck(Mpval(ConTxt), RT_RV, __FILE__, 'a', 'u', 'u', Mpval(m), Mpval(n), Mpval(lda), 1, Mpaddress(rsrc), Mpaddress(csrc)); #endif if (Mpval(lda) < Mpval(m)) tlda = Mpval(m); else tlda = Mpval(lda); ctxt->scp = &ctxt->pscp; MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda, MPI_FLOAT, &BI_AuxBuff.N); BI_AuxBuff.Buff = (char *) A; BI_AuxBuff.dtype = MatTyp; BI_Srecv(ctxt, Mkpnum(ctxt, Mpval(rsrc), Mpval(csrc)), PT2PTID, &BI_AuxBuff); ierr=MPI_Type_free(&MatTyp); if (BI_ActiveQ) BI_UpdateBuffs(NULL); }
F_VOID_FUNC zgebr2d_(int *ConTxt, F_CHAR scope, F_CHAR top, int *m, int *n, double *A, int *lda, int *rsrc, int *csrc) #endif /* * -- V1.1 BLACS routine -- * University of Tennessee, May 1, 1996 * Written by Clint Whaley. * * Purpose * ======= * Broadcast/receive for general double complex arrays. * * Arguments * ========= * * ConTxt (input) Ptr to int * Index into MyConTxts00 (my contexts array). * * SCOPE (input) Ptr to char * Limit the scope of the operation. * = 'R' : Operation is performed by a process row. * = 'C' : Operation is performed by a process column. * = 'A' : Operation is performed by all processes in grid. * * TOP (input) Ptr to char * Controls fashion in which messages flow within the operation. * * M (input) Ptr to int * The number of rows of the matrix A. M >= 0. * * N (input) Ptr to int * The number of columns of the matrix A. N >= 0. * * A (output) Ptr to double complex two dimensional array * The m by n matrix A. Fortran77 (column-major) storage * assumed. * * LDA (input) Ptr to int * The leading dimension of the array A. LDA >= M. * * * RSRC (input) Ptr to int * The process row of the source of the matrix. * * CSRC (input) Ptr to int * The process column of the source of the matrix. * * * ------------------------------------------------------------------------ */ { void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int, int *, int *); int BI_HypBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int); void BI_IdringBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int); void BI_SringBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int); void BI_MpathBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int); void BI_TreeBR(BLACSCONTEXT *, BLACBUFF *, SDRVPTR, int, int); void BI_UpdateBuffs(BLACBUFF *); BLACBUFF *BI_GetBuff(int); int BI_BuffIsFree(BLACBUFF *, int); MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int, MPI_Datatype, int *); void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype); void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *); void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *); BLACSCONTEXT *ctxt; BLACBUFF *bp=NULL; SDRVPTR send; MPI_Datatype MatTyp; int length, src, tlda, error, one=1; char ttop, tscope; extern BLACBUFF BI_AuxBuff, *BI_ActiveQ; MGetConTxt(Mpval(ConTxt), ctxt); ttop = F2C_CharTrans(top); ttop = Mlowcase(ttop); tscope = F2C_CharTrans(scope); tscope = Mlowcase(tscope); #if (BlacsDebugLvl > 0) BI_ArgCheck(Mpval(ConTxt), RT_BR, __FILE__, tscope, 'u', 'u', Mpval(m), Mpval(n), Mpval(lda), 1, Mpaddress(rsrc), Mpaddress(csrc)); #endif /* * If the user has set the default broadcast topology, use it instead of * BLACS default */ #ifdef DefBSTop if (ttop == ' ') ttop = DefBSTop; #endif if (Mpval(m) <= Mpval(lda)) tlda = Mpval(lda); else tlda = Mpval(m); switch(tscope) { case 'r': ctxt->scp = &ctxt->rscp; src = Mpval(csrc); break; case 'c': ctxt->scp = &ctxt->cscp; src = Mpval(rsrc); break; case 'a': ctxt->scp = &ctxt->ascp; src = Mvkpnum(ctxt, Mpval(rsrc), Mpval(csrc)); break; default: BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'", tscope); } MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda, MPI_DOUBLE_COMPLEX, &BI_AuxBuff.N); /* * If using default topology, use MPI native broadcast */ if (ttop == ' ') { error=MPI_Bcast(A, BI_AuxBuff.N, MatTyp, src, ctxt->scp->comm); error=BI_MPI_TYPE_FREE(&MatTyp); if (BI_ActiveQ) BI_UpdateBuffs(NULL); return; } /* * If MPI handles non-contiguous buffering well, always use MPI data types * instead of packing */ #ifndef MpiBuffGood /* * If A is contiguous, receive and send directly to/from it */ else if ( (tlda == Mpval(m)) || (Mpval(n) == 1) ) { #endif send = BI_Ssend; BI_AuxBuff.Buff = (char *) A; BI_AuxBuff.dtype = MatTyp; bp = &BI_AuxBuff; #ifndef MpiBuffGood } /* * If A is not contiguous, we receive message as packed so it can be * forwarded without further system intervention */ else { send = BI_Asend; MPI_Pack_size(one, MatTyp, ctxt->scp->comm, &length); bp = BI_GetBuff(length); bp->N = length; bp->dtype = MPI_PACKED; #if ZeroByteTypeBug if (MatTyp == MPI_BYTE) { send = BI_Ssend; bp->N = 0; bp->dtype = MPI_BYTE; } #endif } #endif switch(ttop) { case 'h': error = BI_HypBR(ctxt, bp, send, src); if (error == NPOW2) BI_TreeBR(ctxt, bp, send, src, 2); break; case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': BI_TreeBR(ctxt, bp, send, src, ttop-47); break; case 't': BI_TreeBR(ctxt, bp, send, src, ctxt->Nb_bs); break; case 'i': BI_IdringBR(ctxt, bp, send, src, 1); break; case 'd': BI_IdringBR(ctxt, bp, send, src, -1); break; case 's': BI_SringBR(ctxt, bp, send, src); break; case 'm': BI_MpathBR(ctxt, bp, send, src, ctxt->Nr_bs); break; case 'f': BI_MpathBR(ctxt, bp, send, src, FULLCON); break; default : BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'", ttop); } /* * If we buffered, unpack. */ #ifndef MpiBuffGood if (bp != &BI_AuxBuff) { BI_Unpack(ctxt, (BVOID *) A, bp, MatTyp); BI_UpdateBuffs(bp); } else #endif { error=BI_MPI_TYPE_FREE(&MatTyp); if (BI_ActiveQ) BI_UpdateBuffs(NULL); } }
F_VOID_FUNC igesd2d_(int *ConTxt, int *m, int *n, int *A, int *lda, int *rdest, int *cdest) #endif /* * -- V1.1 BLACS routine -- * University of Tennessee, May 1, 1996 * Written by Clint Whaley. * * Purpose * ======= * Locally-blocking point-to-point general integer send. * * Arguments * ========= * * ConTxt (input) Ptr to int * Index into MyConTxts00 (my contexts array). * * M (input) Ptr to int * The number of rows of the matrix A. M >= 0. * * N (input) Ptr to int * The number of columns of the matrix A. N >= 0. * * A (input) Ptr to integer two dimensional array * The m by n matrix A. Fortran77 (column-major) storage * assumed. * * LDA (input) Ptr to int * The leading dimension of the array A. LDA >= M. * * RDEST (input) Ptr to int * The process row of the destination process. * * CDEST (input) Ptr to int * The process column of the destination process. * * ------------------------------------------------------------------------ */ { void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int, int *, int *); MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int, MPI_Datatype, int *); BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype); void BI_Ssend(BLACSCONTEXT *, int, int, BLACBUFF *); void BI_Asend(BLACSCONTEXT *, int, int, BLACBUFF *); void BI_UpdateBuffs(BLACBUFF *); BLACBUFF *BI_GetBuff(int); int BI_BuffIsFree(BLACBUFF *, int); int dest, tlda, ierr; BLACBUFF *bp; BLACSCONTEXT *ctxt; MPI_Datatype MatTyp; extern BLACBUFF BI_AuxBuff, *BI_ActiveQ; MGetConTxt(Mpval(ConTxt), ctxt); #if (BlacsDebugLvl > 0) BI_ArgCheck(Mpval(ConTxt), RT_SD, "IGESD2D", 'a', 'u', 'u', Mpval(m), Mpval(n), Mpval(lda), 1, Mpaddress(rdest), Mpaddress(cdest)); #endif if (Mpval(lda) < Mpval(m)) tlda = Mpval(m); else tlda = Mpval(lda); dest = Mvkpnum(ctxt, Mpval(rdest), Mpval(cdest)); ctxt->scp = &ctxt->pscp; MatTyp = BI_GetMpiGeType(ctxt, Mpval(m), Mpval(n), tlda, MPI_INT, &BI_AuxBuff.N); #ifdef SndIsLocBlk BI_AuxBuff.Buff = (char *) A; BI_AuxBuff.dtype = MatTyp; BI_Ssend(ctxt, dest, PT2PTID, &BI_AuxBuff); #else bp = BI_Pack(ctxt, (BVOID *) A, NULL, MatTyp); BI_Asend(ctxt, Mkpnum(ctxt, Mpval(rdest), Mpval(cdest)), PT2PTID, bp); #endif ierr=MPI_Type_free(&MatTyp); /* * Having started the async send, update the buffers (reform links, check if * active buffers have become inactive, etc.) */ #ifdef SndIsLocBlk if (BI_ActiveQ) BI_UpdateBuffs(NULL); #else BI_UpdateBuffs(bp); #endif } /* end of igesd2d */