/*@@
@routine CactusDefaultnProcs
@date Tue Jan 23 1999
@author Gabrielle Allen
@desc
Default Cactus nProcs routine.
@enddesc
@calls CCTK_ParamCheckNProcs
MPI_Comm_size
@var GH
@vdesc Pointer to CCTK grid hierarchy
@vtype const cGH *
@vio unused
@endvar
@returntype int
@returndesc
the total number of processors
@endreturndesc
@@*/
int CactusDefaultnProcs (const cGH *GH)
{
int nprocs;
/* avoid compiler warning about unused parameter */
GH = GH;
if (CCTK_ParamChecking ())
{
nprocs = CCTK_ParamCheckNProcs ();
}
else
{
nprocs = 1;
#ifdef CCTK_MPI
if(MPI_Active)
{
CACTUS_MPI_ERROR (MPI_Comm_size (MPI_COMM_WORLD, &nprocs));
}
#endif
}
return (nprocs);
}
/*@@
@routine CactusDefaultShutdown
@date Tue Sep 29 12:45:04 1998
@author Tom Goodale
@desc
Default shutdown routine.
@enddesc
@calls
@calledby
@history introducing CCTK_SHUTDOWN scheduling [03/00 Gerd Lanfermann]
@endhistory
@@*/
int CactusDefaultShutdown(tFleshConfig *config)
{
int myproc;
unsigned int conv_level;
myproc = CCTK_MyProc(config->GH[0]);
/* Execute termination for all convergence levels */
for(conv_level = 0 ; conv_level < config->nGHs; conv_level++)
{
CCTK_Traverse(config->GH[conv_level], "CCTK_TERMINATE");
}
/* Execute shutdown for all convergence levels */
for(conv_level = 0 ; conv_level < config->nGHs; conv_level++)
{
CCTK_Traverse(config->GH[conv_level], "CCTK_SHUTDOWN");
}
#ifdef CCTK_MPI
if(MPI_Active)
{
CACTUS_MPI_ERROR(MPI_Finalize());
}
#endif
if(myproc == 0)
{
printf("--------------------------------------------------------------------------------\n");
printf("Done.\n");
}
return 0;
}
int PUGH_Barrier(const cGH *GH)
{
#ifdef CCTK_MPI
CACTUS_MPI_ERROR (MPI_Barrier (PUGH_pGH (GH)->PUGH_COMM_WORLD));
#else
GH = GH;
#endif
return (0);
}
/*@@
@routine PUGH_Exit
@date Saturday July 15 2000
@author Gabrielle Allen
@desc
PUGH overloadable routine for CCTK_Exit().
@enddesc
@calls MPI_Finalize
exit
@var GH
@vdesc Pointer to CCTK grid hierarchy
@vtype cGH *
@vio in
@endvar
@var retval
@vdesc return code to exit with
@vtype int
@vio in
@endvar
@returntype int
@returndesc
This function should never return.
But if it does it will return the given return code.
@endreturndesc
@@*/
int PUGH_Exit (cGH *GH, int retval)
{
/* avoid compiler warning about unused parameter */
GH = GH;
#ifdef CCTK_MPI
CACTUS_MPI_ERROR (MPI_Finalize ());
#endif
exit (retval);
return (retval);
}
/*@@
@routine CactusDefaultExit
@date Tue Apr 18 15:21:15 2000
@author Gerd Lanfermann
@desc
The default for when people call CCTK_Exit.
@enddesc
@calls MPI_Finalize
exit
@var GH
@vdesc Pointer to CCTK grid hierarchy
@vtype cGH *
@vio unused
@endvar
@var retval
@vdesc return code to exit with
@vtype int
@vio in
@endvar
@returntype int
@returndesc
This function should never return.
But if it does it will return 0.
@endreturndesc
@@*/
int CactusDefaultExit (cGH *GH, int retval)
{
/* avoid compiler warning about unused parameter */
GH = GH;
#ifdef CCTK_MPI
if(MPI_Active)
{
CACTUS_MPI_ERROR (MPI_Finalize ());
}
#endif
exit (retval);
return (0);
}
/*@@
@routine PUGH_nProcs
@date Tue Jan 23 1999
@author Gabrielle Allen
@desc
PUGH overloadable routine for CCTK_nProcs().
@enddesc
@calls MPI_Comm_size
@var GH
@vdesc Pointer to CCTK grid hierarchy
@vtype const cGH *
@vio in
@endvar
@returntype int
@returndesc
the total number of processors
@endreturndesc
@@*/
int PUGH_nProcs (const cGH *GH)
{
int nprocs;
#ifdef CCTK_MPI
CACTUS_MPI_ERROR (MPI_Comm_size (GH ? PUGH_pGH (GH)->PUGH_COMM_WORLD :
MPI_COMM_WORLD, &nprocs));
#else
GH = GH;
nprocs = 1;
#endif
return (nprocs);
}
/*@@
@routine PUGH_MyProc
@date Tue Jan 23 1999
@author Gabrielle Allen
@desc
PUGH overloadable routine for CCTK_MyProc().
@enddesc
@calls MPI_Comm_rank
@var GH
@vdesc Pointer to CCTK grid hierarchy
@vtype const cGH *
@vio in
@endvar
@returntype int
@returndesc
the processor number of the caller
@endreturndesc
@@*/
int PUGH_MyProc (const cGH *GH)
{
int myproc;
#ifdef CCTK_MPI
CACTUS_MPI_ERROR (MPI_Comm_rank (GH ? PUGH_pGH (GH)->PUGH_COMM_WORLD :
MPI_COMM_WORLD, &myproc));
#else
GH = GH;
myproc = 0;
#endif
return (myproc);
}
/*@@
@routine CactusDefaultMyProc
@date Tue Jan 23 1999
@author Gabrielle Allen
@desc
Default Cactus MyProc routine.
@enddesc
@calls CCTK_ParamChecking
MPI_Comm_rank
@var GH
@vdesc Pointer to CCTK grid hierarchy
@vtype const cGH *
@vio unused
@endvar
@returntype int
@returndesc
the processor number of the caller
@endreturndesc
@@*/
int CactusDefaultMyProc (const cGH *GH)
{
int myproc;
/* avoid compiler warning about unused parameter */
GH = GH;
myproc = 0;
#ifdef CCTK_MPI
if(! CCTK_ParamChecking() && MPI_Active)
{
CACTUS_MPI_ERROR (MPI_Comm_rank (MPI_COMM_WORLD, &myproc));
}
#endif
return (myproc);
}
/*@@
@routine PUGH_Abort
@date Saturday July 15 2000
@author Gabrielle Allen
@desc
PUGH overloadable routine for CCTK_Abort().
@enddesc
@calls MPI_Abort
exit
@var GH
@vdesc Pointer to CCTK grid hierarchy
@vtype cGH *
@vio in
@endvar
@var retval
@vdesc return code to abort with
@vtype int
@vio in
@endvar
@returntype int
@returndesc
This function should never return.
But if it does it will return 0.
@endreturndesc
@@*/
int PUGH_Abort (cGH *GH, int retval)
{
#ifdef CCTK_MPI
/* flush stdout and stderr before calling MPI_Abort() because
some MPI implementations simply kill other MPI processes */
fflush (stdout);
fflush (stderr);
CACTUS_MPI_ERROR (MPI_Abort (GH ? PUGH_pGH (GH)->PUGH_COMM_WORLD :
MPI_COMM_WORLD, retval));
#else
/* avoid compiler warning about unused parameter */
GH = GH;
retval = retval;
/* FIXME */
/*abort();*/
#endif
exit (0);
return (0);
}
/*@@
@routine CactusDefaultAbort
@date Saturday July 15 2000
@author Gabrielle Allen
@desc
The default for when people call CCTK_Abort.
@enddesc
@calls MPI_Abort
exit
@var GH
@vdesc Pointer to CCTK grid hierarchy
@vtype cGH *
@vio unused
@endvar
@var retval
@vdesc return code to abort with
@vtype int
@vio in
@endvar
@returntype int
@returndesc
This function should never return.
But if it does it will return 0.
@endreturndesc
@@*/
int CactusDefaultAbort (cGH *GH, int retval)
{
/* avoid compiler warning about unused parameter */
GH = GH;
#ifdef CCTK_MPI
if (MPI_Active)
{
/* flush stdout and stderr before calling MPI_Abort() because
some MPI implementations simply kill other MPI processes */
fflush (stdout);
fflush (stderr);
CACTUS_MPI_ERROR (MPI_Abort (MPI_COMM_WORLD, retval));
}
#else
/* FIXME */
/*abort();*/
retval = retval;
#endif
exit (0);
return (0);
}
/*@@
@routine Setup_nProcs
@date Tue Apr 18 15:21:42 2000
@author Tom Goodale
@desc
Setup PUGH_COMM_WORLD communicator and make sure that CCTK_INT
and CCTK_REAL sizes are the same on all processors.
Define MPI datatypes for CCTK_REAL and CCTK_COMPLEX variables.
@enddesc
@var pughGH
@vdesc Pointer to PUGH grid hierarchy
@vtype pGH *
@vio in
@endvar
@var dim
@vdesc dimension of processor topology to set up
@vtype int
@vio in
@endvar
@returntype int
@returndesc
0 for success
@endreturndesc
@@*/
static int Setup_nProcs (pGH *pughGH, int dim)
{
#ifdef CCTK_MPI
CCTK_REAL4 sum_sizes [2], compiled_sizes [2];
/* Set up my communicator. This would allow us to run pugh on
a subset of processors at a later date if, for instance, we
were using panda or what not.
*/
CACTUS_MPI_ERROR (MPI_Comm_dup (MPI_COMM_WORLD, &pughGH->PUGH_COMM_WORLD));
CACTUS_MPI_ERROR (MPI_Comm_size (pughGH->PUGH_COMM_WORLD, &pughGH->nprocs));
CACTUS_MPI_ERROR (MPI_Comm_rank (pughGH->PUGH_COMM_WORLD, &pughGH->myproc));
/* check that all executables uses the same integer and fp precision
within a metacomputing environment
NOTE: We cannot use CCTK_INT4s in MPI_Allreduce() since
(although they have the same size) they might be correspond to
different MPI datatypes.
CCTK_REAL4 should always refer to MPI_FLOAT. */
compiled_sizes [0] = sizeof (CCTK_INT);
compiled_sizes [1] = sizeof (CCTK_REAL);
CACTUS_MPI_ERROR (MPI_Allreduce (compiled_sizes, sum_sizes, 2, PUGH_MPI_REAL4,
MPI_SUM, pughGH->PUGH_COMM_WORLD));
if (compiled_sizes [0] * pughGH->nprocs != sum_sizes [0])
{
CCTK_WARN (0, "Cannot run executables with different precision for "
"CCTK_INTs within a metacomputing environment !\n"
"Please configure with unique CCTK_INTEGER_PRECISION !");
}
if (compiled_sizes [1] * pughGH->nprocs != sum_sizes [1])
{
CCTK_WARN (0, "Cannot run executables with different precision for "
"CCTK_REALs within a metacomputing environment !\n"
"Please configure with unique CCTK_REAL_PRECISION !");
}
/* define the complex datatype as a concatanation of 2 PUGH_MPI_REALs */
CACTUS_MPI_ERROR (MPI_Type_contiguous (2, PUGH_MPI_REAL,
&pughGH->PUGH_mpi_complex));
CACTUS_MPI_ERROR (MPI_Type_commit (&pughGH->PUGH_mpi_complex));
/* dito for fixed-precision reals */
#ifdef CCTK_REAL4
CACTUS_MPI_ERROR (MPI_Type_contiguous (2, PUGH_MPI_REAL4,
&pughGH->PUGH_mpi_complex8));
CACTUS_MPI_ERROR (MPI_Type_commit (&pughGH->PUGH_mpi_complex8));
#endif
#ifdef CCTK_REAL8
CACTUS_MPI_ERROR (MPI_Type_contiguous (2, PUGH_MPI_REAL8,
&pughGH->PUGH_mpi_complex16));
CACTUS_MPI_ERROR (MPI_Type_commit (&pughGH->PUGH_mpi_complex16));
#endif
#ifdef CCTK_REAL16
CACTUS_MPI_ERROR (MPI_Type_contiguous (2, PUGH_MPI_REAL16,
&pughGH->PUGH_mpi_complex32));
CACTUS_MPI_ERROR (MPI_Type_commit (&pughGH->PUGH_mpi_complex32));
#endif
#else
pughGH->nprocs = 1;
pughGH->myproc = 0;
#endif
pughGH->dim = dim;
return (0);
}
/*@@
@routine PUGH_DestroyPGH
@date Thu Aug 21 11:38:10 1997
@author Paul Walker
@desc
Destroys a GH object.
@enddesc
@var GHin
@vdesc address of PUGH GH extensions object to be destroyed
@vtype pGH **
@vio in
@endvar
@@*/
void PUGH_DestroyPGH (pGH **GHin)
{
pGH *GH;
pGA *GA;
cGroup pgroup;
int i;
int variable;
int group;
int this_var;
GH = *GHin;
#ifdef CCTK_MPI
CACTUS_MPI_ERROR (MPI_Comm_free (&GH->PUGH_COMM_WORLD));
CACTUS_MPI_ERROR (MPI_Type_free (&GH->PUGH_mpi_complex));
#ifdef CCTK_REAL4
CACTUS_MPI_ERROR (MPI_Type_free (&GH->PUGH_mpi_complex8));
#endif
#ifdef CCTK_REAL8
CACTUS_MPI_ERROR (MPI_Type_free (&GH->PUGH_mpi_complex16));
#endif
#ifdef CCTK_REAL16
CACTUS_MPI_ERROR (MPI_Type_free (&GH->PUGH_mpi_complex32));
#endif
#endif
/* Great. Now go about the work of destroying me. */
variable = 0;
for(group = 0; group < CCTK_NumGroups(); group++)
{
#ifdef DEBUG_PUGH
printf("Calling Destroying Group %s\n", CCTK_GroupName(group));
fflush(stdout);
#endif
CCTK_GroupData(group,&pgroup);
if (pgroup.grouptype == CCTK_ARRAY || pgroup.grouptype == CCTK_GF)
{
GA = (pGA *) GH->variables[variable][0];
/* Destroy group comm buffers */
if (GA->groupcomm)
{
if (GA->groupcomm->commflag != PUGH_NOCOMM)
{
PUGH_DisableGArrayGroupComm (GH, variable, GA->groupcomm);
}
PUGH_DestroyComm (&GA->groupcomm);
}
/* Destroy the group's connectivity and extras structure
for CCTK_ARRAY groups.
Remember that the connectivity and extras for CCTK_GF types
are shared between all such groups and are destroyed later. */
if (GA->connectivity != GH->Connectivity[pgroup.dim-1])
{
PUGH_DestroyConnectivity (&GA->connectivity);
}
if (GA->extras != GH->GFExtras[pgroup.dim-1])
{
PUGH_DestroyPGExtras (&GA->extras);
}
}
for (this_var = 0; this_var < pgroup.numvars; this_var++, variable++)
{
for(i = 0 ; i < pgroup.numtimelevels; i++)
{
switch(pgroup.grouptype)
{
case CCTK_GF:
case CCTK_ARRAY:
PUGH_DestroyGArray(&(((pGA ***)GH->variables)[variable][i]));
break;
case CCTK_SCALAR:
if (GH->variables[variable][i])
{
free(GH->variables[variable][i]);
}
break;
}
}
free(GH->variables[variable]);
}
}
for (i=1;i<=GH->dim;i++)
{
PUGH_DestroyConnectivity(&GH->Connectivity[i-1]);
PUGH_DestroyPGExtras(&GH->GFExtras[i-1]);
}
if(GH->identity_string)
{
free(GH->identity_string);
}
free(GH->Connectivity);
free(GH->GFExtras);
free(GH->variables);
free(GH);
*GHin = NULL;
}
/*@@
@routine PUGH_Sync
@date Mon Jun 05 2000
@author Thomas Radke
@desc
Finally synchronizes a variable or group of variables
according to a given comm structure.
@enddesc
@calls PUGH_SyncSingleProc
@history
@endhistory
@@*/
static int PUGH_Sync(pGH *pughGH,
pComm *comm)
{
#ifdef CCTK_MPI
int dir;
pGA *GA;
MPI_Status mss;
#ifdef PUGH_WITH_DERIVED_DATATYPES
int i;
MPI_Request *sr;
#endif
#ifdef COMM_TIMING
double t1, t2;
#endif
#endif
/* single-processor case in handled in separate routine */
if (pughGH->nprocs == 1)
{
return (PUGH_SyncSingleProc (pughGH, comm));
}
#ifdef CCTK_MPI
/* start the timer for communication time */
if (pughGH->comm_time >= 0)
{
CCTK_TimerStartI (pughGH->comm_time);
}
GA = (pGA *) pughGH->variables [comm->first_var][comm->sync_timelevel];
#ifdef PUGH_WITH_DERIVED_DATATYPES
if (pughGH->commmodel == PUGH_DERIVEDTYPES)
{
/* 2 faces, send and receive is the 2 * 2 */
sr = (MPI_Request *) malloc(comm->n_vars * 2 * 2 * sizeof(MPI_Request));
}
#endif
#ifdef DEBUG_PUGH
printf (" PUGH_Sync: syncing group of %d vars with first var '%s'\n",
comm->n_vars, GA->name);
fflush (stdout);
#endif
for (dir = 0; dir < GA->extras->dim; dir ++)
{
#ifdef COMM_TIMING
t1 = MPI_Wtime();
#endif
PostReceiveGA(pughGH, 2*dir, comm);
PostReceiveGA(pughGH, 2*dir+1, comm);
#ifdef COMM_TIMING
t2 = MPI_Wtime();
printf("PR : %f\n",t2-t1);
#endif
PostSendGA(pughGH, 2*dir, comm);
PostSendGA(pughGH, 2*dir+1, comm);
#ifdef COMM_TIMING
t1 = MPI_Wtime();
printf("PS : %f\n",t1-t2);
#endif
/* Now comes the big difference between derived types and
allocated buffers. With derived types, we now have to
wait on all our recieve AND SEND buffers so we can
keep on using the send buffers ( as communications are
in-place). With the allocated we have to wait on each
recieve, but not on the send, since we don't need the
send buffer until we pack a send again (above)
*/
if (pughGH->commmodel == PUGH_ALLOCATEDBUFFERS)
{
/* Do a wait any on the receives */
MPI_Wait(&comm->rreq[2*dir], &mss);
FinishReceiveGA(pughGH, 2*dir, comm);
MPI_Wait(&comm->rreq[2*dir+1], &mss);
FinishReceiveGA(pughGH, 2*dir+1, comm);
}
#ifdef PUGH_WITH_DERIVED_DATATYPES
else if (pughGH->commmodel == PUGH_DERIVEDTYPES)
{
/* Load up the thing for the waitall */
for (i = 0; i < comm->n_vars; i++)
{
int id = i * 2 * 2;
pGA *GA = (pGA *) pughGH->variables [i][comm->sync_timelevel];
if (GA->comm->docomm[2*dir] &&
GA->storage)
{
sr[id] = GA->comm->sreq[2*dir];
sr[id+1] = GA->comm->rreq[2*dir];
}
else
{
sr[id] = MPI_REQUEST_NULL;
sr[id+1] = MPI_REQUEST_NULL;
}
if (GA->comm->docomm[2*dir+1] &&
GA->storage)
{
sr[id+2] = GA->comm->sreq[2*dir+1];
sr[id+3] = GA->comm->rreq[2*dir+1];
}
else
{
sr[id+2] = MPI_REQUEST_NULL;
sr[id+3] = MPI_REQUEST_NULL;
}
}
/* Now do a waitall */
MPI_Waitall(4*comm->n_vars, sr, &mss);
}
#endif
#ifdef COMM_TIMING
t2 = MPI_Wtime();
printf("FR : %f\n",t2-t1);
#endif
}
#ifdef PUGH_WITH_DERIVED_DATATYPES
if (pughGH->commmodel == PUGH_DERIVEDTYPES)
{
free(sr);
}
else
#endif
{
/* wait for MPI to finish all outstanding send requests */
CACTUS_MPI_ERROR (MPI_Waitall (2 * GA->extras->dim, comm->sreq,
comm->sstatus));
}
/* get the time spent in communication */
if (pughGH->comm_time >= 0)
{
CCTK_TimerStopI(pughGH->comm_time);
}
#endif /* CCTK_MPI */
return (0);
}
