mtest.c

mpi并行计算的c++代码 可用vc或gcc编译通过 可以用来搭建并行计算试验环境

	recvtype->InitBuf  = MTestTypeVectorInit;
	sendtype->InitBuf  = MTestTypeContigInitRecv;
	recvtype->FreeBuf  = MTestTypeVectorFree;
	sendtype->FreeBuf  = MTestTypeContigFree;
	recvtype->CheckBuf = MTestTypeVectorCheckbuf;
	sendtype->CheckBuf = 0;
	break;
    case 7:
	/* contig send and block indexed recv */
	/* Make indexes 5*((count-1) - i), for i=0, ..., count-1, i.e., 
	   every 5th element, but starting from the end. */
	recvtype->blksize  = sizeof(int);
	recvtype->nelm     = recvtype->count;

	sendtype->displs = (int *) malloc( sendtype->count );
	if (!sendtype->displs) {
	    MTestError( "Out of memory in indexed block" );
	}
	for (i=0; i<sendtype->count; i++) {
	    sendtype->displs[i] = 5 * ( (count-1) - i );
	}
	sendtype->basesize = sizeof(int);
	sendtype->nelm     = sendtype->count;
	MPI_Type_create_index_block( sendtype->count, 1, sendtype->displs, 
				     MPI_INT, &recvtype->datatype );
        MPI_Type_commit( &recvtype->datatype );
	MPI_Type_set_name( recvtype->datatype, "int-decreasing-indexed" );
	recvtype->count    = 1;
	sendtype->datatype = MPI_INT;
	sendtype->isBasic  = 1;
	recvtype->InitBuf  = MTestTypeIndexedInit;
	sendtype->InitBuf  = MTestTypeContigInitRecv;
	recvtype->FreeBuf  = MTestTypeIndexedFree;
	sendtype->FreeBuf  = MTestTypeContigFree;
	recvtype->CheckBuf = MTestTypeIndexedCheckBuf;
	sendtype->CheckBuf = 0;
	break;
    case 8: 
	/* index send and vector recv (using shorts) */
	break;
#endif
    default:
	datatype_index = -1;
    }

    if (!sendtype->InitBuf) {
	sendtype->InitBuf  = MTestTypeContigInit;
	recvtype->InitBuf  = MTestTypeContigInitRecv;
	sendtype->FreeBuf  = MTestTypeContigFree;
	recvtype->FreeBuf  = MTestTypeContigFree;
	sendtype->CheckBuf = MTestTypeContigCheckbuf;
	recvtype->CheckBuf = MTestTypeContigCheckbuf;
    }
    datatype_index++;

    if (dbgflag && datatype_index > 0) {
	int typesize;
	fprintf( stderr, "%d: sendtype is %s\n", wrank, MTestGetDatatypeName( sendtype ) );
	MPI_Type_size( sendtype->datatype, &typesize );
	fprintf( stderr, "%d: sendtype size = %d\n", wrank, typesize );
	fprintf( stderr, "%d: recvtype is %s\n", wrank, MTestGetDatatypeName( recvtype ) );
	MPI_Type_size( recvtype->datatype, &typesize );
	fprintf( stderr, "%d: recvtype size = %d\n", wrank, typesize );
	fflush( stderr );
	
    }
    return datatype_index;
}

/* Reset the datatype index (start from the initial data type.
   Note: This routine is rarely needed; MTestGetDatatypes automatically
   starts over after the last available datatype is used.
*/
void MTestResetDatatypes( void )
{
    datatype_index = 0;
}
/* Return the index of the current datatype.  This is rarely needed and
   is provided mostly to enable debugging of the MTest package itself */
int MTestGetDatatypeIndex( void )
{
    return datatype_index;
}

/* Free the storage associated with a datatype */
void MTestFreeDatatype( MTestDatatype *mtype )
{
    /* Invoke a datatype-specific free function to handle
       both the datatype and the send/receive buffers */
    if (mtype->FreeBuf) {
	(mtype->FreeBuf)( mtype );
    }
    /* Free the datatype itself if it was created */
    if (!mtype->isBasic) {
	MPI_Type_free( &mtype->datatype );
    }
}

/* Check that a message was received correctly.  Returns the number of
   errors detected.  Status may be NULL or MPI_STATUS_IGNORE */
int MTestCheckRecv( MPI_Status *status, MTestDatatype *recvtype )
{
    int count;
    int errs = 0;

    if (status && status != MPI_STATUS_IGNORE) {
	MPI_Get_count( status, recvtype->datatype, &count );
	
	/* Check count against expected count */
	if (count != recvtype->count) {
	    errs ++;
	}
    }

    /* Check received data */
    if (!errs && recvtype->CheckBuf( recvtype )) {
	errs++;
    }
    return errs;
}

/* This next routine uses a circular buffer of static name arrays just to
   simplify the use of the routine */
const char *MTestGetDatatypeName( MTestDatatype *dtype )
{
    static char name[4][MPI_MAX_OBJECT_NAME];
    static int sp=0;
    int rlen;

    if (sp >= 4) sp = 0;
    MPI_Type_get_name( dtype->datatype, name[sp], &rlen );
    return (const char *)name[sp++];
}
/* ----------------------------------------------------------------------- */

/* 
 * Create communicators.  Use separate routines for inter and intra
 * communicators (there is a routine to give both)
 * Note that the routines may return MPI_COMM_NULL, so code should test for
 * that return value as well.
 * 
 */
static int interCommIdx = 0;
static int intraCommIdx = 0;
static const char *intraCommName = 0;
static const char *interCommName = 0;

/* 
 * Get an intracommunicator with at least min_size members.  If "allowSmaller"
 * is true, allow the communicator to be smaller than MPI_COMM_WORLD and
 * for this routine to return MPI_COMM_NULL for some values.  Returns 0 if
 * no more communicators are available.
 */
int MTestGetIntracommGeneral( MPI_Comm *comm, int min_size, int allowSmaller )
{
    int size, rank;
    int done=0;
    int isBasic = 0;

    /* The while loop allows us to skip communicators that are too small.
       MPI_COMM_NULL is always considered large enough */
    while (!done) {
	switch (intraCommIdx) {
	case 0:
	    *comm = MPI_COMM_WORLD;
	    isBasic = 1;
	    intraCommName = "MPI_COMM_WORLD";
	    break;
	case 1:
	    /* dup of world */
	    MPI_Comm_dup(MPI_COMM_WORLD, comm );
	    intraCommName = "Dup of MPI_COMM_WORLD";
	    break;
	case 2:
	    /* reverse ranks */
	    MPI_Comm_size( MPI_COMM_WORLD, &size );
	    MPI_Comm_rank( MPI_COMM_WORLD, &rank );
	    MPI_Comm_split( MPI_COMM_WORLD, 0, size-rank, comm );
	    intraCommName = "Rank reverse of MPI_COMM_WORLD";
	    break;
	case 3:
	    /* subset of world, with reversed ranks */
	    MPI_Comm_size( MPI_COMM_WORLD, &size );
	    MPI_Comm_rank( MPI_COMM_WORLD, &rank );
	    MPI_Comm_split( MPI_COMM_WORLD, (rank < size/2), size-rank, comm );
	    intraCommName = "Rank reverse of half of MPI_COMM_WORLD";
	    break;
	case 4:
	    *comm = MPI_COMM_SELF;
	    isBasic = 1;
	    intraCommName = "MPI_COMM_SELF";
	    break;

	    /* These next cases are communicators that include some
	       but not all of the processes */
	case 5:
	case 6:
	case 7:
	case 8:
	{
	    int newsize;
	    MPI_Comm_size( MPI_COMM_WORLD, &size );
	    newsize = size - (intraCommIdx - 4);
	    
	    if (allowSmaller && newsize >= min_size) {
		MPI_Comm_rank( MPI_COMM_WORLD, &rank );
		MPI_Comm_split( MPI_COMM_WORLD, rank < newsize, rank, comm );
		if (rank >= newsize) {
		    MPI_Comm_free( comm );
		    *comm = MPI_COMM_NULL;
		}
	    }
	    else {
		/* Act like default */
		*comm = MPI_COMM_NULL;
		isBasic = 1;
		intraCommName = "MPI_COMM_NULL";
		intraCommIdx = -1;
	    }
	}
	break;
	    
	    /* Other ideas: dup of self, cart comm, graph comm */
	default:
	    *comm = MPI_COMM_NULL;
	    isBasic = 1;
	    intraCommName = "MPI_COMM_NULL";
	    intraCommIdx = -1;
	    break;
	}

	if (*comm != MPI_COMM_NULL) {
	    MPI_Comm_size( *comm, &size );
	    if (size >= min_size) 
		done = 1;
	    else {
		/* Try again */
		if (!isBasic) MPI_Comm_free( comm );
		intraCommIdx++;
	    }
	}
	else
	    done = 1;
    }

    intraCommIdx++;
    return intraCommIdx;
}

/* 
 * Get an intracommunicator with at least min_size members.
 */
int MTestGetIntracomm( MPI_Comm *comm, int min_size ) 
{
    return MTestGetIntracommGeneral( comm, min_size, 0 );
}

/* Return the name of an intra communicator */
const char *MTestGetIntracommName( void )
{
    return intraCommName;
}

/* 
 * Return an intercomm; set isLeftGroup to 1 if the calling process is 
 * a member of the "left" group.
 */
int MTestGetIntercomm( MPI_Comm *comm, int *isLeftGroup, int min_size )
{
    int size, rank, remsize;
    int done=0;
    MPI_Comm mcomm;
    int rleader;

    /* The while loop allows us to skip communicators that are too small.
       MPI_COMM_NULL is always considered large enough.  The size is
       the sum of the sizes of the local and remote groups */
    while (!done) {
	switch (interCommIdx) {
	case 0:
	    /* Split comm world in half */
	    MPI_Comm_rank( MPI_COMM_WORLD, &rank );
	    MPI_Comm_size( MPI_COMM_WORLD, &size );
	    if (size > 1) {
		MPI_Comm_split( MPI_COMM_WORLD, (rank < size/2), rank, 
				&mcomm );
		if (rank == 0) {
		    rleader = size/2;
		}
		else if (rank == size/2) {
		    rleader = 0;
		}
		else {
		    /* Remote leader is signficant only for the processes
		       designated local leaders */
		    rleader = -1;
		}
		*isLeftGroup = rank < size/2;
		MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader, 12345,
				      comm );
		MPI_Comm_free( &mcomm );
		interCommName = "Intercomm by splitting MPI_COMM_WORLD";
	    }
	    else 
		*comm = MPI_COMM_NULL;
	    break;
	case 1:
	    /* Split comm world in to 1 and the rest */
	    MPI_Comm_rank( MPI_COMM_WORLD, &rank );
	    MPI_Comm_size( MPI_COMM_WORLD, &size );
	    if (size > 1) {
		MPI_Comm_split( MPI_COMM_WORLD, rank == 0, rank, 
				&mcomm );
		if (rank == 0) {
		    rleader = 1;
		}
		else if (rank == 1) {
		    rleader = 0;
		}
		else {
		    /* Remote leader is signficant only for the processes
		       designated local leaders */
		    rleader = -1;
		}
		*isLeftGroup = rank == 0;
		MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader, 12346,
				      comm );
		MPI_Comm_free( &mcomm );
		interCommName = "Intercomm by splitting MPI_COMM_WORLD into 1, rest";
	    }
	    else 
		*comm = MPI_COMM_NULL;
	    break;

	case 2:
	    /* Split comm world in to 2 and the rest */
	    MPI_Comm_rank( MPI_COMM_WORLD, &rank );
	    MPI_Comm_size( MPI_COMM_WORLD, &size );
	    if (size > 3) {
		MPI_Comm_split( MPI_COMM_WORLD, rank < 2, rank, 
				&mcomm );
		if (rank == 0) {
		    rleader = 2;
		}
		else if (rank == 2) {
		    rleader = 0;
		}
		else {
		    /* Remote leader is signficant only for the processes
		       designated local leaders */
		    rleader = -1;
		}
		*isLeftGroup = rank < 2;
		MPI_Intercomm_create( mcomm, 0, MPI_COMM_WORLD, rleader, 12347,
				      comm );
		MPI_Comm_free( &mcomm );
		interCommName = "Intercomm by splitting MPI_COMM_WORLD into 2, rest";
	    }
	    else 
		*comm = MPI_COMM_NULL;
	    break;
	    
	default:
	    *comm = MPI_COMM_NULL;
	    interCommName = "MPI_COMM_NULL";
	    interCommIdx = -1;
	    break;
	}
	if (*comm != MPI_COMM_NULL) {
	    MPI_Comm_size( *comm, &size );
	    MPI_Comm_remote_size( *comm, &remsize );
	    if (size + remsize >= min_size) done = 1;
	}
	else
	    done = 1;
    }

    interCommIdx++;
    return interCommIdx;
}
/* Return the name of an intercommunicator */
const char *MTestGetIntercommName( void )
{
    return interCommName;
}

/* Get a communicator of a given minimum size.  Both intra and inter 
   communicators are provided */
int MTestGetComm( MPI_Comm *comm, int min_size )
{
    int idx=0;
    static int getinter = 0;

    if (!getinter) {
	idx = MTestGetIntracomm( comm, min_size );
	if (idx == 0) {
	    getinter = 1;
	}
    }
    if (getinter) {
	int isLeft;
	idx = MTestGetIntercomm( comm, &isLeft, min_size );
	if (idx == 0) {
	    getinter = 0;
	}
    }

    return idx;
}

/* Free a communicator.  It may be called with a predefined communicator
 or MPI_COMM_NULL */
void MTestFreeComm( MPI_Comm *comm )
{
    if (*comm != MPI_COMM_WORLD &&
	*comm != MPI_COMM_SELF &&
	*comm != MPI_COMM_NULL) {
	MPI_Comm_free( comm );
    }
}

/* ------------------------------------------------------------------------ */
void MTestPrintError( int errcode )
{
    int errclass, slen;
    char string[MPI_MAX_ERROR_STRING];
    
    MPI_Error_class( errcode, &errclass );
    MPI_Error_string( errcode, string, &slen );
    printf( "Error class %d (%s)\n", errclass, string );
    fflush( stdout );
}
void MTestPrintErrorMsg( const char msg[], int errcode )
{
    int errclass, slen;
    char string[MPI_MAX_ERROR_STRING];
    
    MPI_Error_class( errcode, &errclass );
    MPI_Error_string( errcode, string, &slen );
    printf( "%s: Error class %d (%s)\n", msg, errclass, string ); 
    fflush( stdout );
}
/* ------------------------------------------------------------------------ */
void MTestPrintfMsg( int level, const char format[], ... )
{
    va_list list;
    int n;

    if (verbose && level >= verbose) {
	va_start(list,format);
	n = vprintf( format, list );
	va_end(list);
	fflush(stdout);
    }
}
/* Fatal error.  Report and exit */
void MTestError( const char *msg )
{
    fprintf( stderr, "%s\n", msg );
    fflush( stderr );
    MPI_Abort( MPI_COMM_WORLD, 1 );
}
/* ------------------------------------------------------------------------ */
#ifdef HAVE_MPI_WIN_CREATE
/*
 * Create MPI Windows
 */
static int win_index = 0;
static const char *winName;
/* Use an attribute to remember the type of memory allocation (static,
   malloc, or MPI_Alloc_mem) */
static int mem_keyval = MPI_KEYVAL_INVALID;
int MTestGetWin( MPI_Win *win, int mustBePassive )
{
    static char actbuf[1024];
    static char *pasbuf;
    char        *buf;
    int         n, rank;
    MPI_Info    info;

    if (mem_keyval == MPI_KEYVAL_INVALID) {
	/* Create the keyval */
	MPI_Win_create_keyval( MPI_WIN_NULL_COPY_FN, MPI_WIN_NULL_DELETE_FN, 
			       &mem_keyval, 0 );
    }

    switch (win_index) {
    case 0:
	/* Active target window */
	MPI_Win_create( actbuf, 1024, 1, MPI_INFO_NULL, MPI_COMM_WORLD, 
			win );
	winName = "active-window";
	MPI_Win_set_attr( *win, mem_keyval, (void *)0 );
	break;
    case 1:
	/* Passive target window */
	MPI_Alloc_mem( 1024, MPI_INFO_NULL, &pasbuf );
	MPI_Win_create( pasbuf, 1024, 1, MPI_INFO_NULL, MPI_COMM_WORLD, 
			win );
	winName = "passive-window";
	MPI_Win_set_attr( *win, mem_keyval, (void *)2 );
	break;
    case 2:
	/* Active target; all windows different sizes */
	MPI_Comm_rank( MPI_COMM_WORLD, &rank );
	n = rank * 64;
	if (n) 
	    buf = (char *)malloc( n );
	else
	    buf = 0;
	MPI_Win_create( buf, n, 1, MPI_INFO_NULL, MPI_COMM_WORLD, 
			win );
	winName = "active-all-different-win";
	MPI_Win_set_attr( *win, mem_keyval, (void *)1 );
	break;
    case 3:
	/* Active target, no locks set */
	MPI_Comm_rank( MPI_COMM_WORLD, &rank );
	n = rank * 64;
	if (n) 
	    buf = (char *)malloc( n );
	else
	    buf = 0;
	MPI_Info_create( &info );
	MPI_Info_set( info, "nolocks", "true" );
	MPI_Win_create( buf, n, 1, info, MPI_COMM_WORLD, win );
	MPI_Info_free( &info );
	winName = "active-nolocks-all-different-win";
	MPI_Win_set_attr( *win, mem_keyval, (void *)1 );
	break;
    default:
	win_index = -1;
    }
    win_index++;
    return win_index;
}
/* Return a pointer to the name associated with a window object */
const char *MTestGetWinName( void )
{
    return winName;
}
/* Free the storage associated with a window object */
void MTestFreeWin( MPI_Win *win )
{
    void *addr;
    int  flag;

    MPI_Win_get_attr( *win, MPI_WIN_BASE, &addr, &flag );
    if (!flag) {
	MTestError( "Could not get WIN_BASE from window" );
    }
    if (addr) {
	void *val;
	MPI_Win_get_attr( *win, mem_keyval, &val, &flag );
	if (flag) {
	    if (val == (void *)1) {
		free( addr );
	    }
	    else if (val == (void *)2) {
		MPI_Free_mem( addr );
	    }
	    /* if val == (void *)0, then static data that must not be freed */
	}
    }
    MPI_Win_free(win);
}
#endif