F_VOID_FUNC blacs_exit_(int *NotDone)
#endif
{
void BI_UpdateBuffs(BLACBUFF *);
BLACBUFF *BI_GetBuff(int);
int BI_BuffIsFree(BLACBUFF *, int);
BLACBUFF *bp;
extern BLACBUFF *BI_ReadyB, *BI_ActiveQ, BI_AuxBuff;
int i;
extern int BI_MaxNCtxt, BI_Np;
extern BLACSCONTEXT **BI_MyContxts;
/*
* Destroy all contexts
*/
for (i=0; i < BI_MaxNCtxt; i++) if (BI_MyContxts[i]) Cblacs_gridexit(i);
free(BI_MyContxts);
if (BI_ReadyB) free(BI_ReadyB);
while (BI_ActiveQ != NULL)
{
bp = BI_ActiveQ;
BI_BuffIsFree(bp, 1); /* wait for async sends to complete */
BI_ActiveQ = bp->next;
free(bp);
}
free (BI_AuxBuff.Aops);
/*
* Reset parameters to initial values
*/
BI_MaxNCtxt = 0;
BI_MyContxts = NULL;
BI_Np = -1;
if (!Mpval(NotDone))
{
MPI_Finalize();
}
BI_ReadyB = NULL;
}
F_VOID_FUNC igsum2d_(int *ConTxt, F_CHAR scope, F_CHAR top, 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
* =======
* Combine sum operation for integer rectangular matrices.
*
* 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 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 of the sum.
* If rdest == -1, then result is left on all processes in scope.
*
* CDEST (input) Ptr to int
* The process column of the destination of the sum.
* If rdest == -1, then CDEST ignored.
*
* ------------------------------------------------------------------------
*/
{
void BI_ArgCheck(int, int, char *, char, char, char, int, int, int, int,
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 *);
BLACBUFF *BI_Pack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
MPI_Datatype BI_GetMpiGeType(BLACSCONTEXT *, int, int, int,
MPI_Datatype, int *);
void BI_Unpack(BLACSCONTEXT *, BVOID *, BLACBUFF *, MPI_Datatype);
void BI_MringComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
int, int);
void BI_TreeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR,
int, int);
void BI_BeComb(BLACSCONTEXT *, BLACBUFF *, BLACBUFF *, int, VVFUNPTR);
void BI_ivvsum(int, char *, char *);
/*
* Variable Declarations
*/
BLACBUFF *bp, *bp2;
BLACSCONTEXT *ctxt;
char ttop, tscope;
int N, length, dest, tlda, trdest, ierr, itr;
extern BLACBUFF *BI_ActiveQ;
extern BLACBUFF BI_AuxBuff;
MGetConTxt(Mpval(ConTxt), ctxt);
ttop = F2C_CharTrans(top);
ttop = Mlowcase(ttop);
tscope = F2C_CharTrans(scope);
tscope = Mlowcase(tscope);
/*
* If the user has set the default combine topology, use it instead of
* BLACS default
*/
#ifdef DefCombTop
if (ttop == ' ') ttop = DefCombTop;
#endif
if (Mpval(cdest) == -1) trdest = -1;
else trdest = Mpval(rdest);
#if (BlacsDebugLvl > 0)
BI_ArgCheck(Mpval(ConTxt), RT_COMB, __FILE__, tscope, 'u', 'u', Mpval(m),
Mpval(n), Mpval(lda), 1, &trdest, Mpaddress(cdest));
#endif
if (Mpval(lda) >= Mpval(m)) tlda = Mpval(lda);
else tlda = Mpval(m);
switch(tscope)
{
case 'r':
ctxt->scp = &ctxt->rscp;
if (trdest == -1) dest = -1;
else dest = Mpval(cdest);
break;
case 'c':
ctxt->scp = &ctxt->cscp;
dest = trdest;
break;
case 'a':
ctxt->scp = &ctxt->ascp;
if (trdest == -1) dest = -1;
else dest = Mvkpnum(ctxt, trdest, Mpval(cdest));
break;
default:
BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown scope '%c'",
tscope);
}
/*
* It's not defined how MPI reacts to 0 element reductions, so use BLACS 1-tree
* topology if we've got one. Note that integer operations are always
* repeatable.
*/
if (ttop == ' ') if ( (Mpval(m) < 1) || (Mpval(n) < 1) ) ttop = '1';
N = Mpval(m) * Mpval(n);
length = N * sizeof(int);
/*
* If A is contiguous, we can use it as one of the buffers
*/
if ( (Mpval(m) == tlda) || (Mpval(n) == 1) )
{
bp = &BI_AuxBuff;
bp->Buff = (char *) A;
bp2 = BI_GetBuff(length);
}
/*
* Otherwise, we must allocate both buffers
*/
else
{
bp = BI_GetBuff(length*2);
bp2 = &BI_AuxBuff;
bp2->Buff = &bp->Buff[length];
BI_imvcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
}
bp->dtype = bp2->dtype = MPI_INT;
bp->N = bp2->N = N;
switch(ttop)
{
case ' ': /* use MPI's reduction by default */
if (dest != -1)
{
ierr=MPI_Reduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, MPI_SUM,
dest, ctxt->scp->comm);
if (ctxt->scp->Iam == dest)
BI_ivmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
}
else
{
ierr=MPI_Allreduce(bp->Buff, bp2->Buff, bp->N, bp->dtype, MPI_SUM,
ctxt->scp->comm);
BI_ivmcopy(Mpval(m), Mpval(n), A, tlda, bp2->Buff);
}
if (BI_ActiveQ) BI_UpdateBuffs(NULL);
return;
break;
case 'i':
BI_MringComb(ctxt, bp, bp2, N, BI_ivvsum, dest, 1);
break;
case 'd':
BI_MringComb(ctxt, bp, bp2, N, BI_ivvsum, dest, -1);
break;
case 's':
BI_MringComb(ctxt, bp, bp2, N, BI_ivvsum, dest, 2);
break;
case 'm':
BI_MringComb(ctxt, bp, bp2, N, BI_ivvsum, dest, ctxt->Nr_co);
break;
case '1':
case '2':
case '3':
case '4':
case '5':
case '6':
case '7':
case '8':
case '9':
BI_TreeComb(ctxt, bp, bp2, N, BI_ivvsum, dest, ttop-47);
break;
case 'f':
BI_TreeComb(ctxt, bp, bp2, N, BI_ivvsum, dest, FULLCON);
break;
case 't':
BI_TreeComb(ctxt, bp, bp2, N, BI_ivvsum, dest, ctxt->Nb_co);
break;
case 'h':
/*
* Use bidirectional exchange if everyone wants answer
*/
if ( (trdest == -1) && !(ctxt->TopsCohrnt) )
BI_BeComb(ctxt, bp, bp2, N, BI_ivvsum);
else
BI_TreeComb(ctxt, bp, bp2, N, BI_ivvsum, dest, 2);
break;
default :
BI_BlacsErr(Mpval(ConTxt), __LINE__, __FILE__, "Unknown topology '%c'",
ttop);
}
/*
* If I am selected to receive answer
*/
if (bp != &BI_AuxBuff)
{
if ( (ctxt->scp->Iam == dest) || (dest == -1) )
BI_ivmcopy(Mpval(m), Mpval(n), A, tlda, bp->Buff);
BI_UpdateBuffs(bp);
}
else
{
if (BI_ActiveQ) BI_UpdateBuffs(NULL);
BI_BuffIsFree(bp, 1);
}
}
