commutil.c

fortran并行计算包

	}

	if (own_mask) {
	    /* There is a chance that we've found a context id */
	    /* MPIU_THREAD_SINGLE_CS_ENTER("context_id"); */
	    /* Find_context_bit updates the context array if it finds a match */
	    context_id = MPIR_Find_context_bit( local_mask );
	    MPIU_DBG_MSG_D( COMM, VERBOSE, 
			    "Context id is now %d", context_id );
	    if (context_id > 0) {
		/* If we were the lowest context id, reset the value to
		   allow the other threads to compete for the mask */
		if (lowestContextId == comm_ptr->context_id) {
		    lowestContextId = MPIR_MAXID;
		    /* Else leave it alone; there is another thread waiting */
		}
	    }
	    else {
		/* else we did not find a context id. Give up the mask in case
		   there is another thread (with a lower context id) waiting for
		   it.
		   We need to ensure that any other threads have the 
		   opportunity to run.  We do this by releasing the single
		   mutex, yielding, and then reaquiring the mutex.
		   We might want to do something more sophisticated, such
		   as using a condition variable (if we know for sure that
		   there is another thread on this process that is waiting).
		*/
		MPID_Thread_mutex_unlock(&MPIR_ThreadInfo.global_mutex);
		MPID_Thread_yield();
		MPID_Thread_mutex_lock(&MPIR_ThreadInfo.global_mutex);
	    }
	    mask_in_use = 0;
	    /* MPIU_THREAD_SINGLE_CS_EXIT("context_id"); */
	}
	else {
	    /* As above, force this thread to yield */
	    MPID_Thread_mutex_unlock(&MPIR_ThreadInfo.global_mutex);
	    MPID_Thread_yield();
	    MPID_Thread_mutex_lock(&MPIR_ThreadInfo.global_mutex);
	}
    }

    MPIU_DBG_MSG_S(COMM,VERBOSE,"Context mask = %s",MPIR_ContextMaskToStr());

    MPIR_Nest_decr();
    MPID_MPI_FUNC_EXIT(MPID_STATE_MPIR_GET_CONTEXTID);

    return context_id;
}
#endif

/* Get a context for a new intercomm.  There are two approaches 
   here (for MPI-1 codes only)
   (a) Each local group gets a context; the groups exchange, and
       the low value is accepted and the high one returned.  This
       works because the context ids are taken from the same pool.
   (b) Form a temporary intracomm over all processes and use that
       with the regular algorithm.
   
   In some ways, (a) is the better approach because it is the one that
   extends to MPI-2 (where the last step, returning the context, is 
   not used and instead separate send and receive context id value 
   are kept).  For this reason, we'll use (a).

   Even better is to separate the local and remote context ids.  Then
   each group of processes can manage their context ids separately.
*/
/* 
 * This uses the thread-safe (if necessary) routine to get a context id
 * and does not need its own thread-safe version.
 */
#undef FUNCNAME
#define FUNCNAME MPIR_Get_intercomm_contextid
#undef FCNAME
#define FCNAME "MPIR_Get_intercomm_contextid"
int MPIR_Get_intercomm_contextid( MPID_Comm *comm_ptr, int *context_id, 
				  int *recvcontext_id )
{
    int mycontext_id, remote_context_id;
    int mpi_errno = MPI_SUCCESS;
    int tag = 31567; /* FIXME  - we need an internal tag or 
		        communication channel.  Can we use a different
		        context instead?.  Or can we use the tag 
		        provided in the intercomm routine? (not on a dup, 
			but in that case it can use the collective context) */
    MPIU_THREADPRIV_DECL;
    MPID_MPI_STATE_DECL(MPID_STATE_MPIR_GET_INTERCOMM_CONTEXTID);

    MPID_MPI_FUNC_ENTER(MPID_STATE_MPIR_GET_INTERCOMM_CONTEXTID);

    if (!comm_ptr->local_comm) {
	/* Manufacture the local communicator */
	MPIR_Setup_intercomm_localcomm( comm_ptr );
    }

    /*printf( "local comm size is %d and intercomm local size is %d\n",
      comm_ptr->local_comm->local_size, comm_ptr->local_size );*/
    mycontext_id = MPIR_Get_contextid( comm_ptr->local_comm );
    if (mycontext_id == 0) {
	goto fn_fail;
    }

    MPIU_THREADPRIV_GET;

    /* MPIC routine uses an internal context id.  The local leads (process 0)
       exchange data */
    remote_context_id = -1;
    if (comm_ptr->rank == 0) {
	MPIC_Sendrecv( &mycontext_id, 1, MPI_INT, 0, tag,
		       &remote_context_id, 1, MPI_INT, 0, tag, 
		       comm_ptr->handle, MPI_STATUS_IGNORE );
    }

    /* Make sure that all of the local processes now have this
       id */
    MPIR_Nest_incr();
    NMPI_Bcast( &remote_context_id, 1, MPI_INT, 
		0, comm_ptr->local_comm->handle );
    MPIR_Nest_decr();
    /* printf( "intercomm context = %d\n", remote_context_id ); */

    *context_id     = remote_context_id;
    *recvcontext_id = mycontext_id;
 fn_fail:
    MPID_MPI_FUNC_EXIT(MPID_STATE_MPIR_GET_INTERCOMM_CONTEXTID);
    return mpi_errno;
}

#undef FUNCNAME
#define FUNCNAME MPIR_Free_contextid
#undef FCNAME
#define FCNAME "MPIR_Free_contextid"
void MPIR_Free_contextid( int context_id )
{
    int idx, bitpos;
    MPID_MPI_STATE_DECL(MPID_STATE_MPIR_FREE_CONTEXTID);
    
    MPID_MPI_FUNC_ENTER(MPID_STATE_MPIR_FREE_CONTEXTID);

    /* Convert the context id to the bit position */
    /* printf( "Freed id = %d\n", context_id ); */
    context_id >>= 2;       /* Remove the shift of a factor of four */
    idx    = context_id / 32;
    bitpos = context_id % 32;

    /* --BEGIN ERROR HANDLING-- */
    if (idx < 0 || idx >= MAX_CONTEXT_MASK) {
	MPID_Abort( 0, MPI_ERR_INTERN, 1, 
		    "In MPIR_Free_contextid, idx is out of range" );
    }
    /* --END ERROR HANDLING-- */

    /* Check that this context id has been allocated */
#if 0
    /* FIXME: This test should be included */
    if ( (context_mask[idx] & (0x1 << bitpos)) != 0) {
	MPID_Abort( 0, MPI_ERR_INTERN, 1, 
		    "In MPIR_Free_contextid, the context id is not in use" );
    }
#endif
    /* MT: Note that this update must be done atomically in the multithreaded
       case.  In the "one, single lock" implementation, that lock is indeed
       held when this operation is called. */
    context_mask[idx] |= (0x1 << bitpos);

    MPIU_DBG_MSG_FMT(COMM,VERBOSE,(MPIU_DBG_FDEST,
			"Freed context %d, mask[%d] bit %d\n", 
			context_id, idx, bitpos ) );
    MPID_MPI_FUNC_EXIT(MPID_STATE_MPIR_FREE_CONTEXTID);
}

/*
 * Copy a communicator, including creating a new context and copying the
 * virtual connection tables and clearing the various fields.
 * Does *not* copy attributes.  If size is < the size of the (local group
 * in the ) input communicator, copy only the first size elements.  
 * If this process is not a member, return a null pointer in outcomm_ptr.
 * This is only supported in the case where the communicator is in 
 * Intracomm (not an Intercomm).  Note that this is all that is required
 * for cart_create and graph_create.
 *
 * Used by cart_create, graph_create, and dup_create 
 */
#undef FUNCNAME
#define FUNCNAME MPIR_Comm_copy
#undef FCNAME
#define FCNAME "MPIR_Comm_copy"
int MPIR_Comm_copy( MPID_Comm *comm_ptr, int size, MPID_Comm **outcomm_ptr )
{
    int mpi_errno = MPI_SUCCESS;
    int new_context_id, new_recvcontext_id;
    MPID_Comm *newcomm_ptr;
    MPID_MPI_STATE_DECL(MPID_STATE_MPIR_COMM_COPY);

    MPID_MPI_FUNC_ENTER(MPID_STATE_MPIR_COMM_COPY);

    /* Get a new context first.  We need this to be collective over the
       input communicator */
    /* If there is a context id cache in oldcomm, use it here.  Otherwise,
       use the appropriate algorithm to get a new context id.  Be careful
       of intercomms here */
    if (comm_ptr->comm_kind == MPID_INTERCOMM) {
	mpi_errno = 
	    MPIR_Get_intercomm_contextid( 
		 comm_ptr, &new_context_id, &new_recvcontext_id );
    }
    else {
	new_context_id = MPIR_Get_contextid( comm_ptr );
	new_recvcontext_id = new_context_id;
    }
    /* --BEGIN ERROR HANDLING-- */
    if (new_context_id == 0 || mpi_errno != MPI_SUCCESS) {
	mpi_errno = MPIR_Err_create_code( MPI_SUCCESS, MPIR_ERR_RECOVERABLE,
               FCNAME, __LINE__, MPI_ERR_OTHER, "**toomanycomm", 0 );
	goto fn_fail;
    }
    /* --END ERROR HANDLING-- */

    /* This is the local size, not the remote size, in the case of
       an intercomm */
    if (comm_ptr->rank >= size) {
	*outcomm_ptr = 0;
	goto fn_exit;
    }

    /* We're left with the processes that will have a non-null communicator.
       Create the object, initialize the data, and return the result */

    mpi_errno = MPIR_Comm_create( &newcomm_ptr );
    if (mpi_errno) goto fn_fail;

    newcomm_ptr->context_id     = new_context_id;
    newcomm_ptr->recvcontext_id = new_recvcontext_id;

    /* Save the kind of the communicator */
    newcomm_ptr->comm_kind   = comm_ptr->comm_kind;
    newcomm_ptr->local_comm  = 0;

    /* There are two cases here - size is the same as the old communicator,
       or it is smaller.  If the size is the same, we can just add a reference.
       Otherwise, we need to create a new VCRT.  Note that this is the
       test that matches the test on rank above. */
    if (size == comm_ptr->local_size) {
	/* Duplicate the VCRT references */
	MPID_VCRT_Add_ref( comm_ptr->vcrt );
	newcomm_ptr->vcrt = comm_ptr->vcrt;
	newcomm_ptr->vcr  = comm_ptr->vcr;
    }
    else {
	int i;
	/* The "remote" vcr gets the shortened vcrt */
	MPID_VCRT_Create( size, &newcomm_ptr->vcrt );
	MPID_VCRT_Get_ptr( newcomm_ptr->vcrt, 
			   &newcomm_ptr->vcr );
	for (i=0; i<size; i++) {
	    /* For rank i in the new communicator, find the corresponding
	       rank in the input communicator */
	    MPID_VCR_Dup( comm_ptr->vcr[i], &newcomm_ptr->vcr[i] );
	}
    }

    /* If it is an intercomm, duplicate the local vcrt references */
    if (comm_ptr->comm_kind == MPID_INTERCOMM) {
	MPID_VCRT_Add_ref( comm_ptr->local_vcrt );
	newcomm_ptr->local_vcrt = comm_ptr->local_vcrt;
	newcomm_ptr->local_vcr  = comm_ptr->local_vcr;
    }

    /* Set the sizes and ranks */
    newcomm_ptr->rank        = comm_ptr->rank;
    if (comm_ptr->comm_kind == MPID_INTERCOMM) {
	newcomm_ptr->local_size  = comm_ptr->local_size;
	newcomm_ptr->remote_size = comm_ptr->remote_size;
    }
    else {
	newcomm_ptr->local_size  = size;
	newcomm_ptr->remote_size = size;
    }

    /* Inherit the error handler (if any) */
    newcomm_ptr->errhandler = comm_ptr->errhandler;
    if (comm_ptr->errhandler) {
	MPIR_Errhandler_add_ref( comm_ptr->errhandler );
    }

    /* Notify the device of the new communicator */
    MPID_Dev_comm_create_hook(newcomm_ptr);
	    
    /* Start with no attributes on this communicator */
    newcomm_ptr->attributes = 0;
    *outcomm_ptr = newcomm_ptr;

 fn_fail:
 fn_exit:

    MPID_MPI_FUNC_EXIT(MPID_STATE_MPIR_COMM_COPY);

    return mpi_errno;
}

/* Release a reference to a communicator.  If there are no pending
   references, delete the communicator and recover all storage and 
   context ids */
#undef FUNCNAME 
#define FUNCNAME MPIR_Comm_release
#undef FCNAME
#define FCNAME "MPIR_Comm_release"
int MPIR_Comm_release(MPID_Comm * comm_ptr, int isDisconnect)
{
    int mpi_errno = MPI_SUCCESS;
    int inuse;
    MPID_MPI_STATE_DECL(MPID_STATE_MPIR_COMM_RELEASE);

    MPID_MPI_FUNC_ENTER(MPID_STATE_MPIR_COMM_RELEASE);
    
    MPIR_Comm_release_ref( comm_ptr, &inuse );
    if (!inuse) {

	/* Remove the attributes, executing the attribute delete routine.  
           Do this only if the attribute functions are defined. 
	   This must be done first, because if freeing the attributes
	   returns an error, the communicator is not freed */
	if (MPIR_Process.attr_free && comm_ptr->attributes) {
	    /* Temporarily add a reference to this communicator because 
               the attr_free code requires a valid communicator */ 
	    MPIU_Object_add_ref( comm_ptr ); 
	    mpi_errno = MPIR_Process.attr_free( comm_ptr->handle, 
						comm_ptr->attributes );
	    /* Release the temporary reference added before the call to 
               attr_free */ 
	    MPIU_Object_release_ref( comm_ptr, &inuse); 
	}

	if (mpi_errno == MPI_SUCCESS) {
	    /* If this communicator is our parent, and we're disconnecting
	       from the parent, mark that fact */
	    if (MPIR_Process.comm_parent == comm_ptr)
		MPIR_Process.comm_parent = NULL;

	    /* Notify the device that the communicator is about to be 
	       destroyed */
	    MPID_Dev_comm_destroy_hook(comm_ptr);
	    
	    /* Free the VCRT */
	    mpi_errno = MPID_VCRT_Release(comm_ptr->vcrt, isDisconnect);
	    if (mpi_errno != MPI_SUCCESS) {
		MPIU_ERR_POP(mpi_errno);
	    }
            if (comm_ptr->comm_kind == MPID_INTERCOMM) {
                mpi_errno = MPID_VCRT_Release(
		    comm_ptr->local_vcrt, isDisconnect);
		if (mpi_errno != MPI_SUCCESS) {
		    MPIU_ERR_POP(mpi_errno);
		}
                if (comm_ptr->local_comm) 
                    MPIR_Comm_release(comm_ptr->local_comm, isDisconnect );
            }

	    /* Free the context value */
	    MPIR_Free_contextid( comm_ptr->recvcontext_id );

	    /* Free the local and remote groups, if they exist */
            if (comm_ptr->local_group)
                MPIR_Group_release(comm_ptr->local_group);
            if (comm_ptr->remote_group)
                MPIR_Group_release(comm_ptr->remote_group);

  	    MPIU_Handle_obj_free( &MPID_Comm_mem, comm_ptr );  
	    
	    /* Remove from the list of active communicators if 
	       we are supporting message-queue debugging.  We make this
	       conditional on having debugger support since the
	       operation is not constant-time */
	    MPIR_COMML_FORGET( comm_ptr );
	}
	else {
	    /* If the user attribute free function returns an error,
	       then do not free the communicator */
	    MPIR_Comm_add_ref( comm_ptr );
	}
    }

 fn_exit:
    MPID_MPI_FUNC_EXIT(MPID_STATE_MPIR_COMM_RELEASE);
    return mpi_errno;
 fn_fail:
    goto fn_exit;
}