mpe_proff.c

fortran并行计算包

{
    MPI_Request *lrequest = 0;
    MPI_Request local_lrequest[MPIR_USE_LOCAL_ARRAY];
    int i;

    if ((int)*count > 0) {
        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
            MPIR_FALLOC(lrequest,
                        (MPI_Request*)MALLOC(sizeof(MPI_Request)*(int)*count),
                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
                        "MPI_STARTALL" );
        }
        else {
            lrequest = local_lrequest;
        }
        for (i=0; i<(int)*count; i++) {
            lrequest[i] = MPI_Request_f2c( array_of_requests[i] );
        }
        *__ierr = MPI_Startall((int)*count,lrequest);
    }
    else
        *__ierr = MPI_Startall((int)*count,(MPI_Request *)0);

    for (i=0; i<(int)*count; i++) {
        array_of_requests[i] = MPI_Request_c2f( lrequest[i]);
    }
    if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
        FREE( lrequest );
    }
}

void mpi_start_ ( MPI_Fint *, MPI_Fint * );
void mpi_start_( MPI_Fint *request, MPI_Fint *__ierr )
{
    MPI_Request lrequest = MPI_Request_f2c(*request );
    *__ierr = MPI_Start( &lrequest );
    *request = MPI_Request_c2f(lrequest);
}

void mpi_testall_ ( MPI_Fint *, MPI_Fint [], MPI_Fint *,
                    MPI_Fint [][MPI_STATUS_SIZE], MPI_Fint * );
void mpi_testall_( MPI_Fint *count, MPI_Fint array_of_requests[],
                   MPI_Fint *flag,
                   MPI_Fint array_of_statuses[][MPI_STATUS_SIZE],
                   MPI_Fint *__ierr )
{
    int lflag;
    int i;
    MPI_Request *lrequest = 0;
    MPI_Request local_lrequest[MPIR_USE_LOCAL_ARRAY];
    MPI_Status *c_status = 0;
    MPI_Status local_c_status[MPIR_USE_LOCAL_ARRAY];

    if ((int)*count > 0) {
        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
            MPIR_FALLOC(lrequest,
                        (MPI_Request*)MALLOC(sizeof(MPI_Request)*(int)*count),
                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
                        "MPI_TESTALL");
            MPIR_FALLOC(c_status,
                        (MPI_Status*)MALLOC(sizeof(MPI_Status)* (int)*count),
                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
                        "MPI_TESTTALL");
        }
        else {
            lrequest = local_lrequest;
            c_status = local_c_status;
        }
        for (i=0; i<(int)*count; i++) {
            lrequest[i] = MPI_Request_f2c( array_of_requests[i] );
        }

        *__ierr = MPI_Testall((int)*count,lrequest,&lflag,c_status);
        /* By checking for lrequest[i] = 0, we handle persistant requests */
        for (i=0; i<(int)*count; i++) {
             array_of_requests[i] = MPI_Request_c2f( lrequest[i] );
        }
    }
    else
        *__ierr = MPI_Testall((int)*count,(MPI_Request *)0,&lflag,c_status);
    
    *flag = MPIR_TO_FLOG(lflag);
    /* We must only copy for those elements that corresponded to non-null
       requests, and only if there is a change */
#if defined( HAVE_MPI_F_STATUSES_IGNORE )
    if ( (MPI_Fint *) array_of_statuses != MPI_F_STATUSES_IGNORE )
#endif
        if (lflag) {
            for (i=0; i<(int)*count; i++) {
                MPI_Status_c2f( &c_status[i], &(array_of_statuses[i][0]) );
            }
        }

    if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
        FREE( lrequest );
        FREE( c_status );
    }
}

void mpi_testany_ ( MPI_Fint *, MPI_Fint [], MPI_Fint *,
                    MPI_Fint *, MPI_Fint *, MPI_Fint * );
void mpi_testany_( MPI_Fint *count, MPI_Fint array_of_requests[],
                   MPI_Fint *index, MPI_Fint *flag, MPI_Fint *status,
                   MPI_Fint *__ierr )
{
    int lindex;
    int lflag;
    MPI_Request *lrequest;
    MPI_Request local_lrequest[MPIR_USE_LOCAL_ARRAY];
    MPI_Status c_status;
    int i;

    if ((int)*count > 0) {
        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
            MPIR_FALLOC(lrequest,
                        (MPI_Request*)MALLOC(sizeof(MPI_Request)* (int)*count),
                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
                        "MPI_TESTANY");
        }
        else 
            lrequest = local_lrequest;

        for (i=0; i<(int)*count; i++) 
            lrequest[i] = MPI_Request_f2c( array_of_requests[i] );

    }
    else
        lrequest = 0;

    *__ierr = MPI_Testany((int)*count,lrequest,&lindex,&lflag,&c_status);
    if (lindex != -1) {
        if (lflag && !*__ierr) {
            array_of_requests[lindex] = MPI_Request_c2f(lrequest[lindex]);
        }
     }
    if ((int)*count > MPIR_USE_LOCAL_ARRAY) 
        FREE( lrequest );
    
    *flag = MPIR_TO_FLOG(lflag);
    /* See the description of waitany in the standard; the Fortran index ranges
       are from 1, not zero */
    *index = (MPI_Fint)lindex;
    if ((int)*index >= 0)
        *index = *index + 1;

#if defined( HAVE_MPI_F_STATUS_IGNORE )
    if ( status != MPI_F_STATUS_IGNORE )
#endif
        MPI_Status_c2f(&c_status, status);
}

void mpi_test_cancelled_ ( MPI_Fint *, MPI_Fint *, MPI_Fint * );
void mpi_test_cancelled_(MPI_Fint *status, MPI_Fint *flag, MPI_Fint *__ierr)
{
    int lflag;
    MPI_Status c_status;

    MPI_Status_f2c(status, &c_status);
    *__ierr = MPI_Test_cancelled(&c_status, &lflag);
    *flag = MPIR_TO_FLOG(lflag);
}

void mpi_test_ ( MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
void mpi_test_ ( MPI_Fint *request, MPI_Fint *flag, MPI_Fint *status,
                 MPI_Fint *__ierr )
{
    int        l_flag;
    MPI_Status c_status;
    MPI_Request lrequest = MPI_Request_f2c(*request);

    *__ierr = MPI_Test( &lrequest, &l_flag, &c_status);
    *request = MPI_Request_c2f(lrequest);

    *flag = MPIR_TO_FLOG(l_flag);

#if defined( HAVE_MPI_F_STATUS_IGNORE )
    if ( status != MPI_F_STATUS_IGNORE )
#endif
        if (l_flag)
            MPI_Status_c2f(&c_status, status);
}

void mpi_testsome_ ( MPI_Fint *, MPI_Fint [], MPI_Fint *,
                     MPI_Fint [], MPI_Fint [][MPI_STATUS_SIZE],
                     MPI_Fint * );
void mpi_testsome_( MPI_Fint *incount, MPI_Fint array_of_requests[],
                    MPI_Fint *outcount, MPI_Fint array_of_indices[], 
                    MPI_Fint array_of_statuses[][MPI_STATUS_SIZE],
                    MPI_Fint *__ierr )
{
    int i,j,found;
    int loutcount;
    int *l_indices = 0;
    int local_l_indices[MPIR_USE_LOCAL_ARRAY];
    MPI_Request *lrequest = 0;
    MPI_Request local_lrequest[MPIR_USE_LOCAL_ARRAY];
    MPI_Status *c_status = 0;
    MPI_Status local_c_status[MPIR_USE_LOCAL_ARRAY];

    if ((int)*incount > 0) {
        if ((int)*incount > MPIR_USE_LOCAL_ARRAY) {
            MPIR_FALLOC(lrequest,
                       (MPI_Request*)MALLOC(sizeof(MPI_Request)*(int)*incount),
                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
                        "MPI_TESTSOME");

            MPIR_FALLOC(l_indices,(int*)MALLOC(sizeof(int)* (int)*incount),
                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
                        "MPI_TESTSOME" );
            MPIR_FALLOC(c_status,
                        (MPI_Status*)MALLOC(sizeof(MPI_Status)* (int)*incount),
                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED,
                        "MPI_TESTSOME" );
        }
        else {
            lrequest = local_lrequest;
            l_indices = local_l_indices;
            c_status = local_c_status;
        }

        for (i=0; i<(int)*incount; i++) {
            lrequest[i] = MPI_Request_f2c( array_of_requests[i] );
        }
        *__ierr = MPI_Testsome((int)*incount,lrequest,&loutcount,l_indices,
                               c_status);

        /* By checking for lrequest[l_indices[i] =  0, 
           we handle persistant requests */
        for (i=0; i<(int)*incount; i++) {
            if ( i < loutcount ) {
                array_of_requests[l_indices[i]]
                = MPI_Request_c2f(lrequest[l_indices[i]] );
            }
            else {
                found = 0;
                j = 0;
                while ( (!found) && (j<loutcount) ) {
                    if (l_indices[j++] == i)
                        found = 1;
                }
                if (!found)
                    array_of_requests[i] = MPI_Request_c2f( lrequest[i] );
            }
        }
    }
    else
        *__ierr = MPI_Testsome( (int)*incount, (MPI_Request *)0, &loutcount, 
                                l_indices, c_status );

    for (i=0; i<loutcount; i++) {
#if defined( HAVE_MPI_F_STATUSES_IGNORE )
        if ( (MPI_Fint *) array_of_statuses != MPI_F_STATUSES_IGNORE )
#endif
            MPI_Status_c2f(&c_status[i], &(array_of_statuses[i][0]) );
        if (l_indices[i] >= 0)
            array_of_indices[i] = l_indices[i] + 1;
    }
    *outcount = (MPI_Fint)loutcount;
    if ((int)*incount > MPIR_USE_LOCAL_ARRAY) {
        FREE( l_indices );
        FREE( lrequest );
        FREE( c_status );
    }

}

void mpi_type_commit_ ( MPI_Fint *, MPI_Fint * );
void mpi_type_commit_ ( MPI_Fint *datatype, MPI_Fint *__ierr )
{
    MPI_Datatype ldatatype = MPI_Type_f2c(*datatype);
    *__ierr = MPI_Type_commit( &ldatatype );
    *datatype = MPI_Type_c2f(ldatatype);
}

void mpi_type_contiguous_ ( MPI_Fint *, MPI_Fint *, MPI_Fint *, MPI_Fint * );
void mpi_type_contiguous_( MPI_Fint *count, MPI_Fint *old_type,
                           MPI_Fint *newtype, MPI_Fint *__ierr )
{
    MPI_Datatype  ldatatype;

    *__ierr = MPI_Type_contiguous((int)*count, MPI_Type_f2c(*old_type),
                                  &ldatatype);
    *newtype = MPI_Type_c2f(ldatatype);
}

void mpi_type_extent_ ( MPI_Fint *, MPI_Fint *, MPI_Fint * );
void mpi_type_extent_( MPI_Fint *datatype, MPI_Fint *extent, MPI_Fint *__ierr )
{
    MPI_Aint c_extent;
    *__ierr = MPI_Type_extent(MPI_Type_f2c(*datatype), &c_extent);
    /* Really should check for truncation, ala mpi_address_ */
    *extent = (MPI_Fint)c_extent;
}

void mpi_type_free_ ( MPI_Fint *, MPI_Fint * );
void mpi_type_free_ ( MPI_Fint *datatype, MPI_Fint *__ierr )
{
    MPI_Datatype ldatatype = MPI_Type_f2c(*datatype);
    *__ierr = MPI_Type_free(&ldatatype);
    *datatype = MPI_Type_c2f(ldatatype);
}

void mpi_type_hindexed_ ( MPI_Fint *, MPI_Fint [], MPI_Fint [],
                          MPI_Fint *, MPI_Fint *, MPI_Fint * );
void mpi_type_hindexed_( MPI_Fint *count, MPI_Fint blocklens[],
                         MPI_Fint indices[], MPI_Fint *old_type,
                         MPI_Fint *newtype, MPI_Fint *__ierr )
{
    MPI_Aint     *c_indices;
    MPI_Aint     local_c_indices[MPIR_USE_LOCAL_ARRAY];
    int          i, mpi_errno;
    int          *l_blocklens; 
    int          local_l_blocklens[MPIR_USE_LOCAL_ARRAY];
    MPI_Datatype ldatatype;
    static char  myname[] = "MPI_TYPE_HINDEXED";

    if ((int)*count > 0) {
        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
        /* We really only need to do this when 
           sizeof(MPI_Aint) != sizeof(INTEGER) */
            MPIR_FALLOC(c_indices,
                        (MPI_Aint *) MALLOC( *count * sizeof(MPI_Aint) ),
                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, myname );

            MPIR_FALLOC(l_blocklens,(int *) MALLOC( *count * sizeof(int) ),
                        MPIR_COMM_WORLD, MPI_ERR_EXHAUSTED, myname );
        }
        else {
            c_indices = local_c_indices;
            l_blocklens = local_l_blocklens;
        }

        for (i=0; i<(int)*count; i++) {
            c_indices[i] = (MPI_Aint) indices[i];
            l_blocklens[i] = (int) blocklens[i];
        }
        *__ierr = MPI_Type_hindexed((int)*count,l_blocklens,c_indices,
                                    MPI_Type_f2c(*old_type), &ldatatype);
        if ((int)*count > MPIR_USE_LOCAL_ARRAY) {
            FREE( c_indices );
            FREE( l_blocklens );
        }
        *newtype = MPI_Type_c2f(ldatatype);
    }
    else if ((int)*count == 0) {
        *__ierr = MPI_SUCCESS;
        *newtype = 0;
    }
    else {
        mpi_errno = MPER_Err_setmsg( MPI_ERR_COUNT, MPIR_ERR_DEFAULT, myname,
                                     (char *)0, (char *)0, (int)(*count) );
        *__ierr = MPIR_ERROR( MPIR_COMM_WORLD, mpi_errno, myname );
        return;
    }
}

void mpi_type_hvector_ ( MPI_Fint *, MPI_Fint *, MPI_Fint *,
                         MPI_Fint *, MPI_Fint *, MPI_Fint * );
void mpi_type_hvector_( MPI_Fint *count, MPI_Fint *blocklen, MPI_Fint *stride,
                        MPI_Fint *old_type, MPI_Fint *newtype,
                        MPI_Fint *__ierr )
{
    MPI_Aint     c_stride = (MPI_Aint)*stride;
    MPI_Datatype ldatatype;

    *__ierr = MPI_Type_hvector((int)*count, (int)*blocklen, c_stride,
                               MPI_Type_f2c(*old_type),
                               &ldatatype);
    *newtype = MPI_Type_c2f(ldatatype);
}

void mpi_type_indexed_ ( MPI_Fint *, MPI_Fint [], MPI_Fint [],
                         MPI_Fint *, MPI_Fint *, MPI_Fint * );
void mpi_type_indexed_( MPI_Fint *count, MPI_Fint blocklens[],
                        MPI_Fint indices[], MPI_Fint *old_type,
                        MPI_Fint *newtype, MPI_Fint *__ierr )
{
    int          i;
    int          *l_blocklens = 0;