mtest.c

fortran并行计算包

/* -*- Mode: C; c-basic-offset:4 ; -*- */
/*
 *
 *  (C) 2001 by Argonne National Laboratory.
 *      See COPYRIGHT in top-level directory.
 */
#include "mpi.h"
#include "mpitestconf.h"
#include "mpitest.h"
#include <stdio.h>
#include <stdlib.h>
#ifdef HAVE_STDARG_H
#include <stdarg.h>
#endif

/*
 * Utility routines for writing MPI tests.
 *
 * We check the return codes on all MPI routines (other than INIT)
 * to allow the program that uses these routines to select MPI_ERRORS_RETURN
 * as the error handler.  We do *not* set MPI_ERRORS_RETURN because
 * the code that makes use of these routines may not check return
 * codes.
 * 
 */

/* Here is where we could put the includes and definitions to enable
   memory testing */

static int dbgflag = 0;         /* Flag used for debugging */
static int wrank = -1;          /* World rank */
static int verbose = 0;         /* Message level (0 is none) */
/* 
 * Initialize and Finalize MTest
 */

/*
   Initialize MTest, initializing MPI if necessary.  

 Environment Variables:
+ MPITEST_DEBUG - If set (to any value), turns on debugging output
- MPITEST_VERBOSE - If set to a numeric value, turns on that level of
  verbose output.  This is used by the routine 'MTestPrintfMsg'

*/
void MTest_Init( int *argc, char ***argv )
{
    int flag;
    char *envval = 0;

    MPI_Initialized( &flag );
    if (!flag) {
	MPI_Init( argc, argv );
    }
    /* Check for debugging control */
    if (getenv( "MPITEST_DEBUG" )) {
	dbgflag = 1;
	MPI_Comm_rank( MPI_COMM_WORLD, &wrank );
    }

    /* Check for verbose control */
    envval = getenv( "MPITEST_VERBOSE" );
    if (envval) {
	char *s;
	long val = strtol( envval, &s, 0 );
	if (s == envval) {
	    /* This is the error case for strtol */
	    fprintf( stderr, "Warning: %s not valid for MPITEST_VERBOSE\n", 
		     envval );
	    fflush( stderr );
	}
	else {
	    if (val >= 0) {
		verbose = val;
	    }
	    else {
		fprintf( stderr, "Warning: %s not valid for MPITEST_VERBOSE\n", 
			 envval );
		fflush( stderr );
	    }
	}
    }
}

/*
  Finalize MTest.  errs is the number of errors on the calling process; 
  this routine will write the total number of errors over all of MPI_COMM_WORLD
  to the process with rank zero, or " No Errors".
  It does *not* finalize MPI.
 */
void MTest_Finalize( int errs )
{
    int rank, toterrs, merr;

    merr = MPI_Comm_rank( MPI_COMM_WORLD, &rank );
    if (merr) MTestPrintError( merr );

    merr = MPI_Reduce( &errs, &toterrs, 1, MPI_INT, MPI_SUM, 
		      0, MPI_COMM_WORLD );
    if (merr) MTestPrintError( merr );
    if (rank == 0) {
	if (toterrs) {
	    printf( " Found %d errors\n", toterrs );
	}
	else {
	    printf( " No Errors\n" );
	}
	fflush( stdout );
    }
}

/*
 * Miscellaneous utilities, particularly to eliminate OS dependencies
 * from the tests.
 * MTestSleep( seconds )
 */
#ifdef HAVE_WINDOWS_H
#include <windows.h>
void MTestSleep( int sec )
{
    Sleep( 1000 * sec );
}
#else
#include <unistd.h>
void MTestSleep( int sec )
{
    sleep( sec );
}
#endif

/*
 * Datatypes
 *
 * Eventually, this could read a description of a file.  For now, we hard 
 * code the choices.
 *
 * Each kind of datatype has the following functions:
 *    MTestTypeXXXInit     - Initialize a send buffer for that type
 *    MTestTypeXXXInitRecv - Initialize a receive buffer for that type
 *    MTestTypeXXXFree     - Free any buffers associate with that type
 *    MTestTypeXXXCheckbuf - Check that the buffer contains the expected data
 * These routines work with (nearly) any datatype that is of type XXX, 
 * allowing the test codes to create a variety of contiguous, vector, and
 * indexed types, then test them by calling these routines.
 *
 * Available types (for the XXX) are
 *    Contig   - Simple contiguous buffers
 *    Vector   - Simple strided "vector" type
 *    Indexed  - Indexed datatype.  Only for a count of 1 instance of the 
 *               datatype
 */
static int datatype_index = 0;

/* ------------------------------------------------------------------------ */
/* Datatype routines for contiguous datatypes                               */
/* ------------------------------------------------------------------------ */
/* 
 * Setup contiguous buffers of n copies of a datatype.
 */
static void *MTestTypeContigInit( MTestDatatype *mtype )
{
    MPI_Aint size;
    int merr;

    if (mtype->count > 0) {
	signed char *p;
	int  i, totsize;
	merr = MPI_Type_extent( mtype->datatype, &size );
	if (merr) MTestPrintError( merr );
	totsize = size * mtype->count;
	if (!mtype->buf) {
	    mtype->buf = (void *) malloc( totsize );
	}
	p = (signed char *)(mtype->buf);
	if (!p) {
	    /* Error - out of memory */
	    MTestError( "Out of memory in type buffer init" );
	}
	for (i=0; i<totsize; i++) {
	    p[i] = 0xff ^ (i & 0xff);
	}
    }
    else {
	if (mtype->buf) {
	    free( mtype->buf );
	}
	mtype->buf = 0;
    }
    return mtype->buf;
}

/* 
 * Setup contiguous buffers of n copies of a datatype.  Initialize for
 * reception (e.g., set initial data to detect failure)
 */
static void *MTestTypeContigInitRecv( MTestDatatype *mtype )
{
    MPI_Aint size;
    int      merr;

    if (mtype->count > 0) {
	signed char *p;
	int  i, totsize;
	merr = MPI_Type_extent( mtype->datatype, &size );
	if (merr) MTestPrintError( merr );
	totsize = size * mtype->count;
	if (!mtype->buf) {
	    mtype->buf = (void *) malloc( totsize );
	}
	p = (signed char *)(mtype->buf);
	if (!p) {
	    /* Error - out of memory */
	    MTestError( "Out of memory in type buffer init" );
	}
	for (i=0; i<totsize; i++) {
	    p[i] = 0xff;
	}
    }
    else {
	if (mtype->buf) {
	    free( mtype->buf );
	}
	mtype->buf = 0;
    }
    return mtype->buf;
}
static void *MTestTypeContigFree( MTestDatatype *mtype )
{
    if (mtype->buf) {
	free( mtype->buf );
	mtype->buf = 0;
    }
    return 0;
}
static int MTestTypeContigCheckbuf( MTestDatatype *mtype )
{
    unsigned char *p;
    unsigned char expected;
    int  i, totsize, err = 0, merr;
    MPI_Aint size;

    p = (unsigned char *)mtype->buf;
    if (p) {
	merr = MPI_Type_extent( mtype->datatype, &size );
	if (merr) MTestPrintError( merr );
	totsize = size * mtype->count;
	for (i=0; i<totsize; i++) {
	    expected = (0xff ^ (i & 0xff));
	    if (p[i] != expected) {
		err++;
		if (mtype->printErrors && err < 10) {
		    printf( "Data expected = %x but got %x for %dth entry\n",
			    expected, p[i], i );
		    fflush( stdout );
		}
	    }
	}
    }
    return err;
}

/* ------------------------------------------------------------------------ */
/* Datatype routines for vector datatypes                                   */
/* ------------------------------------------------------------------------ */

static void *MTestTypeVectorInit( MTestDatatype *mtype )
{
    MPI_Aint size;
    int      merr;

    if (mtype->count > 0) {
	unsigned char *p;
	int  i, j, k, nc, totsize;

	merr = MPI_Type_extent( mtype->datatype, &size );
	if (merr) MTestPrintError( merr );
	totsize	   = mtype->count * size;
	if (!mtype->buf) {
	    mtype->buf = (void *) malloc( totsize );
	}
	p	   = (unsigned char *)(mtype->buf);
	if (!p) {
	    /* Error - out of memory */
	    MTestError( "Out of memory in type buffer init" );
	}

	/* First, set to -1 */
	for (i=0; i<totsize; i++) p[i] = 0xff;

	/* Now, set the actual elements to the successive values.
	   To do this, we need to run 3 loops */
	nc = 0;
	/* count is usually one for a vector type */
	for (k=0; k<mtype->count; k++) {
	    /* For each element (block) */
	    for (i=0; i<mtype->nelm; i++) {
		/* For each value */
		for (j=0; j<mtype->blksize; j++) {
		    p[j] = (0xff ^ (nc & 0xff));
		    nc++;
		}
		p += mtype->stride;
	    }
	}
    }
    else {
	mtype->buf = 0;
    }
    return mtype->buf;
}

static void *MTestTypeVectorFree( MTestDatatype *mtype )
{
    if (mtype->buf) {
	free( mtype->buf );
	mtype->buf = 0;
    }
    return 0;
}

# if 0
/* The following is the contig init code */
static void *MTestTypeVectorInitRecv( MTestDatatype *mtype )
{
    MPI_Aint size;
    int      merr;

    if (mtype->count > 0) {
	signed char *p;
	int  i, totsize;
	merr = MPI_Type_extent( mtype->datatype, &size );
	if (merr) MTestPrintError( merr );
	totsize = size * mtype->count;
	if (!mtype->buf) {
	    mtype->buf = (void *) malloc( totsize );
	}
	p = (signed char *)(mtype->buf);
	if (!p) {
	    /* Error - out of memory */
	    MTestError( "Out of memory in type buffer init" );
	}
	for (i=0; i<totsize; i++) {
	    p[i] = 0xff;
	}
    }
    else {
	if (mtype->buf) {
	    free( mtype->buf );
	}
	mtype->buf = 0;
    }
    return mtype->buf;
}

static int MTestTypeVectorCheckbuf( MTestDatatype *mtype )
{
    unsigned char *p;
    unsigned char expected;
    int  i, totsize, err = 0, merr;
    MPI_Aint size;

    p = (unsigned char *)mtype->buf;
    if (p) {
	merr = MPI_Type_extent( mtype->datatype, &size );
	if (merr) MTestPrintError( merr );
	totsize = size * mtype->count;

	/* count is usually one for a vector type */
	nc = 0;
	for (k=0; k<mtype->count; k++) {
	    /* For each element (block) */
	    for (i=0; i<mtype->nelm; i++) {
		expected = (0xff ^ (nc & 0xff));
		/* For each value */
		for (j=0; j<mtype->blksize; j++) {
		    if (p[j] != expected) {
			err++;
			if (mtype->printErrors && err < 10) {
			    printf( "Data expected = %x but got %x for %dth entry\n",
				    expected, p[j], j );
			    fflush( stdout );
			}
		    nc++;
		}
		p += mtype->stride;
	    }
	}
    }
    return err;
}
#endif
/* ------------------------------------------------------------------------ */
/* Datatype routines for indexed block datatypes                            */
/* ------------------------------------------------------------------------ */

/* 
 * Setup a buffer for one copy of an indexed datatype. 
 */
static void *MTestTypeIndexedInit( MTestDatatype *mtype )
{
    MPI_Aint totsize;
    int      merr;
    
    if (mtype->count > 1) {
	MTestError( "This datatype is supported only for a single count" );
    }
    if (mtype->count == 1) {
	signed char *p;
	int  i, k, offset, j;

	/* Allocate the send/recv buffer */
	merr = MPI_Type_extent( mtype->datatype, &totsize );
	if (merr) MTestPrintError( merr );
	if (!mtype->buf) {
	    mtype->buf = (void *) malloc( totsize );
	}
	p = (signed char *)(mtype->buf);
	if (!p) {
	    MTestError( "Out of memory in type buffer init\n" );
	}
	/* Initialize the elements */
	/* First, set to -1 */
	for (i=0; i<totsize; i++) p[i] = 0xff;

	/* Now, set the actual elements to the successive values.
	   We require that the base type is a contiguous type */
	k = 0;
	for (i=0; i<mtype->nelm; i++) {
	    int b;
	    /* Compute the offset: */
	    offset = mtype->displs[i] * mtype->basesize;
	    /* For each element in the block */
	    for (b=0; b<mtype->index[i]; b++) {
		for (j=0; j<mtype->basesize; j++) {
		    p[offset+j] = 0xff ^ (k++ & 0xff);
		}
		offset += mtype->basesize;
	    }
	}
    }
    else {
	/* count == 0 */
	if (mtype->buf) {
	    free( mtype->buf );
	}
	mtype->buf = 0;
    }
    return mtype->buf;
}

/* 
 * Setup indexed buffers for 1 copy of a datatype.  Initialize for
 * reception (e.g., set initial data to detect failure)
 */
static void *MTestTypeIndexedInitRecv( MTestDatatype *mtype )
{
    MPI_Aint totsize;
    int      merr;

    if (mtype->count > 1) {
	MTestError( "This datatype is supported only for a single count" );
    }
    if (mtype->count == 1) {
	signed char *p;
	int  i;
	merr = MPI_Type_extent( mtype->datatype, &totsize );
	if (merr) MTestPrintError( merr );
	if (!mtype->buf) {
	    mtype->buf = (void *) malloc( totsize );
	}
	p = (signed char *)(mtype->buf);
	if (!p) {
	    /* Error - out of memory */