FORT_DLL_SPEC void FORT_CALL mpi_ialltoallv_ ( void*v1, MPI_Fint v2[], MPI_Fint v3[], MPI_Fint *v4, void*v5, MPI_Fint v6[], MPI_Fint v7[], MPI_Fint *v8, MPI_Fint *v9, MPI_Fint *v10, MPI_Fint *ierr ){ #ifndef HAVE_MPI_F_INIT_WORKS_WITH_C if (MPIR_F_NeedInit){ mpirinitf_(); MPIR_F_NeedInit = 0; } #endif if (v1 == MPIR_F_MPI_IN_PLACE) v1 = MPI_IN_PLACE; *ierr = MPI_Ialltoallv( v1, v2, v3, (MPI_Datatype)(*v4), v5, v6, v7, (MPI_Datatype)(*v8), (MPI_Comm)(*v9), (MPI_Request *)(v10) ); }
FORT_DLL_SPEC void FORT_CALL mpi_alltoallw_ ( void*v1, MPI_Fint v2[], MPI_Fint v3[], MPI_Fint v4[], void*v5, MPI_Fint v6[], MPI_Fint v7[], MPI_Fint v8[], MPI_Fint *v9, MPI_Fint *ierr ){ #ifndef HAVE_MPI_F_INIT_WORKS_WITH_C if (MPIR_F_NeedInit){ mpirinitf_(); MPIR_F_NeedInit = 0; } #endif if (v1 == MPIR_F_MPI_IN_PLACE) v1 = MPI_IN_PLACE; *ierr = MPI_Alltoallw( v1, v2, v3, (MPI_Datatype *)(v4), v5, v6, v7, (MPI_Datatype *)(v8), (MPI_Comm)(*v9) ); }
FORT_DLL_SPEC void FORT_CALL mpi_igather_ ( void*v1, MPI_Fint *v2, MPI_Fint *v3, void*v4, MPI_Fint *v5, MPI_Fint *v6, MPI_Fint *v7, MPI_Fint *v8, MPI_Fint *v9, MPI_Fint *ierr ){ #ifndef HAVE_MPI_F_INIT_WORKS_WITH_C if (MPIR_F_NeedInit){ mpirinitf_(); MPIR_F_NeedInit = 0; } #endif if (v1 == MPIR_F_MPI_IN_PLACE) v1 = MPI_IN_PLACE; *ierr = MPI_Igather( v1, (int)*v2, (MPI_Datatype)(*v3), v4, (int)*v5, (MPI_Datatype)(*v6), (int)*v7, (MPI_Comm)(*v8), (MPI_Request *)(v9) ); }
FORT_DLL_SPEC void FORT_CALL mpi_scatterv_ ( void*v1, MPI_Fint *v2, MPI_Fint *v3, MPI_Fint *v4, void*v5, MPI_Fint *v6, MPI_Fint *v7, MPI_Fint *v8, MPI_Fint *v9, MPI_Fint *ierr ){ #ifndef HAVE_MPI_F_INIT_WORKS_WITH_C if (MPIR_F_NeedInit){ mpirinitf_(); MPIR_F_NeedInit = 0; } #endif if (v5 == MPIR_F_MPI_IN_PLACE) v5 = MPI_IN_PLACE; *ierr = MPI_Scatterv( v1, v2, v3, (MPI_Datatype)(*v4), v5, (int)*v6, (MPI_Datatype)(*v7), (int)*v8, (MPI_Comm)(*v9) ); }
FORT_DLL_SPEC void FORT_CALL mpi_ireduce_scatter_ ( void*v1, void*v2, MPI_Fint v3[], MPI_Fint *v4, MPI_Fint *v5, MPI_Fint *v6, MPI_Fint *v7, MPI_Fint *ierr ){ #ifndef HAVE_MPI_F_INIT_WORKS_WITH_C if (MPIR_F_NeedInit){ mpirinitf_(); MPIR_F_NeedInit = 0; } #endif if (v1 == MPIR_F_MPI_IN_PLACE) v1 = MPI_IN_PLACE; *ierr = MPI_Ireduce_scatter( v1, v2, v3, (MPI_Datatype)(*v4), (MPI_Op)*v5, (MPI_Comm)(*v6), (MPI_Request *)(v7) ); }
FORT_DLL_SPEC void FORT_CALL mpi_exscan_ ( void*v1, void*v2, MPI_Fint *v3, MPI_Fint *v4, MPI_Fint *v5, MPI_Fint *v6, MPI_Fint *ierr ){ #ifndef HAVE_MPI_F_INIT_WORKS_WITH_C if (MPIR_F_NeedInit){ mpirinitf_(); MPIR_F_NeedInit = 0; } #endif if (v1 == MPIR_F_MPI_IN_PLACE) v1 = MPI_IN_PLACE; *ierr = MPI_Exscan( v1, v2, (int)*v3, (MPI_Datatype)(*v4), (MPI_Op)*v5, (MPI_Comm)(*v6) ); }
FORT_DLL_SPEC void FORT_CALL mpi_sendrecv_ ( void*v1, MPI_Fint *v2, MPI_Fint *v3, MPI_Fint *v4, MPI_Fint *v5, void*v6, MPI_Fint *v7, MPI_Fint *v8, MPI_Fint *v9, MPI_Fint *v10, MPI_Fint *v11, MPI_Fint *v12, MPI_Fint *ierr ){ #ifndef HAVE_MPI_F_INIT_WORKS_WITH_C if (MPIR_F_NeedInit){ mpirinitf_(); MPIR_F_NeedInit = 0; } #endif if (v12 == MPI_F_STATUS_IGNORE) { v12 = (MPI_Fint*)MPI_STATUS_IGNORE; } *ierr = MPI_Sendrecv( v1, (int)*v2, (MPI_Datatype)(*v3), (int)*v4, (int)*v5, v6, (int)*v7, (MPI_Datatype)(*v8), (int)*v9, (int)*v10, (MPI_Comm)(*v11), (MPI_Status *)v12 ); }
FORT_DLL_SPEC void FORT_CALL mpi_mrecv_ ( void*v1, MPI_Fint *v2, MPI_Fint *v3, MPI_Fint *v4, MPI_Fint *v5, MPI_Fint *ierr ){ #ifndef HAVE_MPI_F_INIT_WORKS_WITH_C if (MPIR_F_NeedInit){ mpirinitf_(); MPIR_F_NeedInit = 0; } #endif if (v5 == MPI_F_STATUS_IGNORE) { v5 = (MPI_Fint*)MPI_STATUS_IGNORE; } *ierr = MPI_Mrecv( v1, (int)*v2, (MPI_Datatype)(*v3), (MPI_Message *)(v4), (MPI_Status *)v5 ); }
FORT_DLL_SPEC void FORT_CALL mpi_sendrecv_replace_ ( void*v1, MPI_Fint *v2, MPI_Fint *v3, MPI_Fint *v4, MPI_Fint *v5, MPI_Fint *v6, MPI_Fint *v7, MPI_Fint *v8, MPI_Fint *v9, MPI_Fint *ierr ){ #ifndef HAVE_MPI_F_INIT_WORKS_WITH_C if (MPIR_F_NeedInit){ mpirinitf_(); MPIR_F_NeedInit = 0; } #endif if (v9 == MPI_F_STATUS_IGNORE) { v9 = (MPI_Fint*)MPI_STATUS_IGNORE; } *ierr = MPI_Sendrecv_replace( v1, *v2, (MPI_Datatype)(*v3), *v4, *v5, *v6, *v7, (MPI_Comm)(*v8), (MPI_Status *)v9 ); }
FORT_DLL_SPEC void FORT_CALL mpi_status_set_elements_ ( MPI_Fint *v1, MPI_Fint *v2, MPI_Fint *v3, MPI_Fint *ierr ){ #ifndef HAVE_MPI_F_INIT_WORKS_WITH_C if (MPIR_F_NeedInit){ mpirinitf_(); MPIR_F_NeedInit = 0; } #endif if (v1 == MPI_F_STATUS_IGNORE) { v1 = (MPI_Fint*)MPI_STATUS_IGNORE; } *ierr = MPI_Status_set_elements( (MPI_Status *)v1, (MPI_Datatype)(*v2), (int)*v3 ); }
FORT_DLL_SPEC void FORT_CALL mpi_iallgatherv_ ( void*v1, MPI_Fint *v2, MPI_Fint *v3, void*v4, MPI_Fint v5[], MPI_Fint v6[], MPI_Fint *v7, MPI_Fint *v8, MPI_Fint *v9, MPI_Fint *ierr ){ #ifndef HAVE_MPI_F_INIT_WORKS_WITH_C if (MPIR_F_NeedInit){ mpirinitf_(); MPIR_F_NeedInit = 0; } #endif if (v1 == MPIR_F_MPI_IN_PLACE) v1 = MPI_IN_PLACE; if (v1 == MPIR_F_MPI_BOTTOM) v1 = MPI_BOTTOM; if (v4 == MPIR_F_MPI_BOTTOM) v4 = MPI_BOTTOM; *ierr = MPI_Iallgatherv( v1, (int)*v2, (MPI_Datatype)(*v3), v4, v5, v6, (MPI_Datatype)(*v7), (MPI_Comm)(*v8), (MPI_Request *)(v9) ); }
FORT_DLL_SPEC void FORT_CALL mpi_testall_ ( MPI_Fint *v1, MPI_Fint v2[], MPI_Fint *v3, MPI_Fint v4[], MPI_Fint *ierr ){ int l3; #ifndef HAVE_MPI_F_INIT_WORKS_WITH_C if (MPIR_F_NeedInit){ mpirinitf_(); MPIR_F_NeedInit = 0; } #endif if (v4 == MPI_F_STATUSES_IGNORE) { v4 = (MPI_Fint *)MPI_STATUSES_IGNORE; } *ierr = MPI_Testall( (int)*v1, (MPI_Request *)(v2), &l3, (MPI_Status *)v4 ); if (*ierr == MPI_SUCCESS) *v3 = MPIR_TO_FLOG(l3); }
FORT_DLL_SPEC void FORT_CALL mpi_iprobe_ ( MPI_Fint *v1, MPI_Fint *v2, MPI_Fint *v3, MPI_Fint *v4, MPI_Fint *v5, MPI_Fint *ierr ){ int l4; #ifndef HAVE_MPI_F_INIT_WORKS_WITH_C if (MPIR_F_NeedInit){ mpirinitf_(); MPIR_F_NeedInit = 0; } #endif if (v5 == MPI_F_STATUS_IGNORE) { v5 = (MPI_Fint*)MPI_STATUS_IGNORE; } *ierr = MPI_Iprobe( (int)*v1, (int)*v2, (MPI_Comm)(*v3), &l4, (MPI_Status *)v5 ); if (*ierr == MPI_SUCCESS) *v4 = MPIR_TO_FLOG(l4); }
FORT_DLL_SPEC void FORT_CALL mpi_dist_graph_create_ ( MPI_Fint *v1, MPI_Fint *v2, MPI_Fint v3[], MPI_Fint v4[], MPI_Fint v5[], MPI_Fint v6[], MPI_Fint *v7, MPI_Fint *v8, MPI_Fint *v9, MPI_Fint *ierr ){ int l8; #ifndef HAVE_MPI_F_INIT_WORKS_WITH_C if (MPIR_F_NeedInit){ mpirinitf_(); MPIR_F_NeedInit = 0; } #endif if (v6 == MPIR_F_MPI_UNWEIGHTED) v6 = MPI_UNWEIGHTED; else if (v6 == MPIR_F_MPI_WEIGHTS_EMPTY) v6 = MPI_WEIGHTS_EMPTY; l8 = MPIR_FROM_FLOG(*v8); *ierr = MPI_Dist_graph_create( (MPI_Comm)(*v1), (int)*v2, v3, v4, v5, v6, (MPI_Info)(*v7), l8, (MPI_Comm *)(v9) ); }
FORT_DLL_SPEC void FORT_CALL mpi_file_write_at_all_ ( MPI_Fint *v1, MPI_Offset *v2, void*v3, MPI_Fint *v4, MPI_Fint *v5, MPI_Fint *v6, MPI_Fint *ierr ){ #ifdef MPI_MODE_RDONLY #ifndef HAVE_MPI_F_INIT_WORKS_WITH_C if (MPIR_F_NeedInit){ mpirinitf_(); MPIR_F_NeedInit = 0; } #endif if (v6 == MPI_F_STATUS_IGNORE) { v6 = (MPI_Fint*)MPI_STATUS_IGNORE; } *ierr = MPI_File_write_at_all( MPI_File_f2c(*v1), (MPI_Offset)*v2, v3, (int)*v4, (MPI_Datatype)(*v5), (MPI_Status *)v6 ); #else *ierr = MPI_ERR_INTERN; #endif }
FORT_DLL_SPEC void FORT_CALL mpi_file_read_ordered_ ( MPI_Fint *v1, void*v2, MPI_Fint *v3, MPI_Fint *v4, MPI_Fint *v5, MPI_Fint *ierr ){ #ifdef MPI_MODE_RDONLY #ifndef HAVE_MPI_F_INIT_WORKS_WITH_C if (MPIR_F_NeedInit){ mpirinitf_(); MPIR_F_NeedInit = 0; } #endif if (v5 == MPI_F_STATUS_IGNORE) { v5 = (MPI_Fint*)MPI_STATUS_IGNORE; } *ierr = MPI_File_read_ordered( MPI_File_f2c(*v1), v2, (int)*v3, (MPI_Datatype)(*v4), (MPI_Status *)v5 ); #else *ierr = MPI_ERR_INTERN; #endif }
FORT_DLL_SPEC void FORT_CALL mpi_file_read_at_all_end_ ( MPI_Fint *v1, void*v2, MPI_Fint *v3, MPI_Fint *ierr ){ #ifdef MPI_MODE_RDONLY #ifndef HAVE_MPI_F_INIT_WORKS_WITH_C if (MPIR_F_NeedInit){ mpirinitf_(); MPIR_F_NeedInit = 0; } #endif if (v3 == MPI_F_STATUS_IGNORE) { v3 = (MPI_Fint*)MPI_STATUS_IGNORE; } *ierr = MPI_File_read_at_all_end( MPI_File_f2c(*v1), v2, (MPI_Status *)v3 ); #else *ierr = MPI_ERR_INTERN; #endif }
FORT_DLL_SPEC void FORT_CALL mpi_testany_ ( MPI_Fint *v1, MPI_Fint v2[], MPI_Fint *v3, MPI_Fint *v4, MPI_Fint *v5, MPI_Fint *ierr ){ int l3; int l4; #ifndef HAVE_MPI_F_INIT_WORKS_WITH_C if (MPIR_F_NeedInit){ mpirinitf_(); MPIR_F_NeedInit = 0; } #endif if (v5 == MPI_F_STATUS_IGNORE) { v5 = (MPI_Fint*)MPI_STATUS_IGNORE; } *ierr = MPI_Testany( (int)*v1, (MPI_Request *)(v2), &l3, &l4, (MPI_Status *)v5 ); *v3 = (MPI_Fint)l3; if (l3 >= 0) *v3 = *v3 + 1; if (*ierr == MPI_SUCCESS) *v4 = MPIR_TO_FLOG(l4); }
FORT_DLL_SPEC void FORT_CALL mpi_testsome_ ( MPI_Fint *v1, MPI_Fint v2[], MPI_Fint *v3, MPI_Fint v4[], MPI_Fint v5[], MPI_Fint *ierr ){ #ifndef HAVE_MPI_F_INIT_WORKS_WITH_C if (MPIR_F_NeedInit){ mpirinitf_(); MPIR_F_NeedInit = 0; } #endif if (v5 == MPI_F_STATUSES_IGNORE) { v5 = (MPI_Fint *)MPI_STATUSES_IGNORE; } *ierr = MPI_Testsome( (int)*v1, (MPI_Request *)(v2), v3, v4, (MPI_Status *)v5 ); {int li; for (li=0; li<*v3; li++) { if (v4[li] >= 0) v4[li] += 1; } } }
FORT_DLL_SPEC void FORT_CALL mpi_address_ ( void*v1, MPI_Fint *v2, MPI_Fint *ierr ){ MPI_Aint a, b; *ierr = MPI_Address( v1, &a ); #ifndef HAVE_MPI_F_INIT_WORKS_WITH_C if (MPIR_F_NeedInit){ mpirinitf_(); MPIR_F_NeedInit = 0; } #endif b = a; *v2 = (MPI_Fint)( b ); #ifdef HAVE_AINT_LARGER_THAN_FINT /* Check for truncation */ if ((MPI_Aint)*v2 - b != 0) { *ierr = MPIR_Err_create_code( MPI_SUCCESS, MPIR_ERR_RECOVERABLE, "MPI_Address", __LINE__, MPI_ERR_ARG, "**inttoosmall", 0 ); (void)MPIR_Err_return_comm( 0, "MPI_Address", *ierr ); } #endif }
int MPIR_Init_thread(int * argc, char ***argv, int required, int * provided) { int mpi_errno = MPI_SUCCESS; int has_args; int has_env; int thread_provided; int exit_init_cs_on_failure = 0; /* For any code in the device that wants to check for runtime decisions on the value of isThreaded, set a provisional value here. We could let the MPID_Init routine override this */ #ifdef HAVE_RUNTIME_THREADCHECK MPIR_ThreadInfo.isThreaded = required == MPI_THREAD_MULTIPLE; #endif MPIU_THREAD_CS_INIT; /* FIXME: Move to os-dependent interface? */ #ifdef HAVE_WINDOWS_H /* prevent the process from bringing up an error message window if mpich asserts */ _CrtSetReportMode( _CRT_ASSERT, _CRTDBG_MODE_FILE ); _CrtSetReportFile( _CRT_ASSERT, _CRTDBG_FILE_STDERR ); _CrtSetReportHook2(_CRT_RPTHOOK_INSTALL, assert_hook); #ifdef _WIN64 { /* FIXME: (Windows) This severly degrades performance but fixes alignment issues with the datatype code. */ /* Prevent misaligned faults on Win64 machines */ UINT mode, old_mode; old_mode = SetErrorMode(SEM_NOALIGNMENTFAULTEXCEPT); mode = old_mode | SEM_NOALIGNMENTFAULTEXCEPT; SetErrorMode(mode); } #endif #endif /* We need this inorder to implement IS_THREAD_MAIN */ # if (MPICH_THREAD_LEVEL >= MPI_THREAD_SERIALIZED) && defined(MPICH_IS_THREADED) { MPID_Thread_self(&MPIR_ThreadInfo.master_thread); } # endif #ifdef HAVE_ERROR_CHECKING /* Because the PARAM system has not been initialized, temporarily uncondtionally enable error checks. Once the PARAM system is initialized, this may be reset */ MPIR_Process.do_error_checks = 1; #else MPIR_Process.do_error_checks = 0; #endif /* Initialize necessary subsystems and setup the predefined attribute values. Subsystems may change these values. */ MPIR_Process.attrs.appnum = -1; MPIR_Process.attrs.host = 0; MPIR_Process.attrs.io = 0; MPIR_Process.attrs.lastusedcode = MPI_ERR_LASTCODE; MPIR_Process.attrs.tag_ub = 0; MPIR_Process.attrs.universe = MPIR_UNIVERSE_SIZE_NOT_SET; MPIR_Process.attrs.wtime_is_global = 0; /* Set the functions used to duplicate attributes. These are when the first corresponding keyval is created */ MPIR_Process.attr_dup = 0; MPIR_Process.attr_free = 0; #ifdef HAVE_CXX_BINDING /* Set the functions used to call functions in the C++ binding for reductions and attribute operations. These are null until a C++ operation is defined. This allows the C code that implements these operations to not invoke a C++ code directly, which may force the inclusion of symbols known only to the C++ compiler (e.g., under more non-GNU compilers, including Solaris and IRIX). */ MPIR_Process.cxx_call_op_fn = 0; #endif /* This allows the device to select an alternative function for dimsCreate */ MPIR_Process.dimsCreate = 0; /* "Allocate" from the reserved space for builtin communicators and (partially) initialize predefined communicators. comm_parent is intially NULL and will be allocated by the device if the process group was started using one of the MPI_Comm_spawn functions. */ MPIR_Process.comm_world = MPID_Comm_builtin + 0; MPIR_Comm_init(MPIR_Process.comm_world); MPIR_Process.comm_world->handle = MPI_COMM_WORLD; MPIR_Process.comm_world->context_id = 0 << MPID_CONTEXT_PREFIX_SHIFT; MPIR_Process.comm_world->recvcontext_id = 0 << MPID_CONTEXT_PREFIX_SHIFT; MPIR_Process.comm_world->comm_kind = MPID_INTRACOMM; /* This initialization of the comm name could be done only when comm_get_name is called */ MPIU_Strncpy(MPIR_Process.comm_world->name, "MPI_COMM_WORLD", MPI_MAX_OBJECT_NAME); MPIR_Process.comm_self = MPID_Comm_builtin + 1; MPIR_Comm_init(MPIR_Process.comm_self); MPIR_Process.comm_self->handle = MPI_COMM_SELF; MPIR_Process.comm_self->context_id = 1 << MPID_CONTEXT_PREFIX_SHIFT; MPIR_Process.comm_self->recvcontext_id = 1 << MPID_CONTEXT_PREFIX_SHIFT; MPIR_Process.comm_self->comm_kind = MPID_INTRACOMM; MPIU_Strncpy(MPIR_Process.comm_self->name, "MPI_COMM_SELF", MPI_MAX_OBJECT_NAME); #ifdef MPID_NEEDS_ICOMM_WORLD MPIR_Process.icomm_world = MPID_Comm_builtin + 2; MPIR_Comm_init(MPIR_Process.icomm_world); MPIR_Process.icomm_world->handle = MPIR_ICOMM_WORLD; MPIR_Process.icomm_world->context_id = 2 << MPID_CONTEXT_PREFIX_SHIFT; MPIR_Process.icomm_world->recvcontext_id= 2 << MPID_CONTEXT_PREFIX_SHIFT; MPIR_Process.icomm_world->comm_kind = MPID_INTRACOMM; MPIU_Strncpy(MPIR_Process.icomm_world->name, "MPI_ICOMM_WORLD", MPI_MAX_OBJECT_NAME); /* Note that these communicators are not ready for use - MPID_Init will setup self and world, and icomm_world if it desires it. */ #endif MPIR_Process.comm_parent = NULL; /* Setup the initial communicator list in case we have enabled the debugger message-queue interface */ MPIR_COMML_REMEMBER( MPIR_Process.comm_world ); MPIR_COMML_REMEMBER( MPIR_Process.comm_self ); /* Call any and all MPID_Init type functions */ MPIR_Err_init(); MPIR_Datatype_init(); MPIR_Group_init(); /* MPIU_Timer_pre_init(); */ mpi_errno = MPIR_Param_init_params(); if (mpi_errno) MPIU_ERR_POP(mpi_errno); /* Wait for debugger to attach if requested. */ if (MPIR_PARAM_DEBUG_HOLD) { volatile int hold = 1; while (hold) #ifdef HAVE_USLEEP usleep(100); #endif ; } #if HAVE_ERROR_CHECKING == MPID_ERROR_LEVEL_RUNTIME MPIR_Process.do_error_checks = MPIR_PARAM_ERROR_CHECKING; #endif /* define MPI as initialized so that we can use MPI functions within MPID_Init if necessary */ MPIR_Process.initialized = MPICH_WITHIN_MPI; /* We can't acquire any critical sections until this point. Any * earlier the basic data structures haven't been initialized */ MPIU_THREAD_CS_ENTER(INIT,required); exit_init_cs_on_failure = 1; mpi_errno = MPID_Init(argc, argv, required, &thread_provided, &has_args, &has_env); if (mpi_errno) MPIU_ERR_POP(mpi_errno); /* Capture the level of thread support provided */ MPIR_ThreadInfo.thread_provided = thread_provided; if (provided) *provided = thread_provided; #ifdef HAVE_RUNTIME_THREADCHECK MPIR_ThreadInfo.isThreaded = (thread_provided == MPI_THREAD_MULTIPLE); #endif /* FIXME: Define these in the interface. Does Timer init belong here? */ MPIU_dbg_init(MPIR_Process.comm_world->rank); MPIU_Timer_init(MPIR_Process.comm_world->rank, MPIR_Process.comm_world->local_size); #ifdef USE_MEMORY_TRACING MPIU_trinit( MPIR_Process.comm_world->rank ); /* Indicate that we are near the end of the init step; memory allocated already will have an id of zero; this helps separate memory leaks in the initialization code from leaks in the "active" code */ /* Uncomment this code to leave out any of the MPID_Init/etc memory allocations from the memory leak testing */ /* MPIU_trid( 1 ); */ #endif #ifdef USE_DBG_LOGGING MPIU_DBG_Init( argc, argv, has_args, has_env, MPIR_Process.comm_world->rank ); #endif /* Initialize the C versions of the Fortran link-time constants. We now initialize the Fortran symbols from within the Fortran interface in the routine that first needs the symbols. This fixes a problem with symbols added by a Fortran compiler that are not part of the C runtime environment (the Portland group compilers would do this) */ #if defined(HAVE_FORTRAN_BINDING) && defined(HAVE_MPI_F_INIT_WORKS_WITH_C) mpirinitf_(); #endif /* FIXME: Does this need to come before the call to MPID_InitComplete? For some debugger support, MPIR_WaitForDebugger may want to use MPI communication routines to collect information for the debugger */ #ifdef HAVE_DEBUGGER_SUPPORT MPIR_WaitForDebugger(); #endif /* Let the device know that the rest of the init process is completed */ if (mpi_errno == MPI_SUCCESS) mpi_errno = MPID_InitCompleted(); #if defined(_OSU_MVAPICH_) || defined(_OSU_PSM_) if (is_shmem_collectives_enabled()){ if (check_split_comm(pthread_self())){ int my_id, size; PMPI_Comm_rank(MPI_COMM_WORLD, &my_id); PMPI_Comm_size(MPI_COMM_WORLD, &size); disable_split_comm(pthread_self()); create_2level_comm(MPI_COMM_WORLD, size, my_id); enable_split_comm(pthread_self()); } } #endif /* defined(_OSU_MVAPICH_) || defined(_OSU_PSM_) */ fn_exit: MPIU_THREAD_CS_EXIT(INIT,required); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ /* signal to error handling routines that core services are unavailable */ MPIR_Process.initialized = MPICH_PRE_INIT; if (exit_init_cs_on_failure) { MPIU_THREAD_CS_EXIT(INIT,required); } MPIU_THREAD_CS_FINALIZE; return mpi_errno; /* --END ERROR HANDLING-- */ }
FORT_DLL_SPEC void FORT_CALL mpi_init_thread_ ( MPI_Fint *v1, MPI_Fint *v2, MPI_Fint *ierr ){ mpirinitf_(); MPIR_F_NeedInit = 0; *ierr = MPI_Init_thread( 0, 0, *v1, v2 ); }
int MPIR_Init_thread(int *argc, char ***argv, int required, int *provided) { int mpi_errno = MPI_SUCCESS; int has_args; int has_env; int thread_provided = 0; int exit_init_cs_on_failure = 0; MPIR_Info *info_ptr; #if defined(MPICH_IS_THREADED) bool cs_initialized = false; #endif /* The threading library must be initialized at the very beginning because * it manages all synchronization objects (e.g., mutexes) that will be * initialized later */ { int thread_err; MPL_thread_init(&thread_err); if (thread_err) goto fn_fail; } #ifdef HAVE_HWLOC MPIR_Process.bindset = hwloc_bitmap_alloc(); hwloc_topology_init(&MPIR_Process.hwloc_topology); MPIR_Process.bindset_is_valid = 0; hwloc_topology_set_io_types_filter(MPIR_Process.hwloc_topology, HWLOC_TYPE_FILTER_KEEP_ALL); if (!hwloc_topology_load(MPIR_Process.hwloc_topology)) { MPIR_Process.bindset_is_valid = !hwloc_get_proc_cpubind(MPIR_Process.hwloc_topology, getpid(), MPIR_Process.bindset, HWLOC_CPUBIND_PROCESS); } #endif #ifdef HAVE_NETLOC MPIR_Process.network_attr.u.tree.node_levels = NULL; MPIR_Process.network_attr.network_endpoint = NULL; MPIR_Process.netloc_topology = NULL; MPIR_Process.network_attr.type = MPIR_NETLOC_NETWORK_TYPE__INVALID; if (strlen(MPIR_CVAR_NETLOC_NODE_FILE)) { mpi_errno = netloc_parse_topology(&MPIR_Process.netloc_topology, MPIR_CVAR_NETLOC_NODE_FILE); if (mpi_errno == NETLOC_SUCCESS) { MPIR_Netloc_parse_topology(MPIR_Process.netloc_topology, &MPIR_Process.network_attr); } } #endif /* For any code in the device that wants to check for runtime * decisions on the value of isThreaded, set a provisional * value here. We could let the MPID_Init routine override this */ #if defined MPICH_IS_THREADED MPIR_ThreadInfo.isThreaded = required == MPI_THREAD_MULTIPLE; #endif /* MPICH_IS_THREADED */ #if defined(MPICH_IS_THREADED) mpi_errno = thread_cs_init(); cs_initialized = true; if (mpi_errno) MPIR_ERR_POP(mpi_errno); #endif /* FIXME: Move to os-dependent interface? */ #ifdef HAVE_WINDOWS_H /* prevent the process from bringing up an error message window if mpich * asserts */ _CrtSetReportMode(_CRT_ASSERT, _CRTDBG_MODE_FILE); _CrtSetReportFile(_CRT_ASSERT, _CRTDBG_FILE_STDERR); _CrtSetReportHook2(_CRT_RPTHOOK_INSTALL, assert_hook); #ifdef _WIN64 { /* FIXME: (Windows) This severly degrades performance but fixes alignment * issues with the datatype code. */ /* Prevent misaligned faults on Win64 machines */ UINT mode, old_mode; old_mode = SetErrorMode(SEM_NOALIGNMENTFAULTEXCEPT); mode = old_mode | SEM_NOALIGNMENTFAULTEXCEPT; SetErrorMode(mode); } #endif #endif /* We need this inorder to implement IS_THREAD_MAIN */ #if (MPICH_THREAD_LEVEL >= MPI_THREAD_SERIALIZED) && defined(MPICH_IS_THREADED) { MPID_Thread_self(&MPIR_ThreadInfo.master_thread); } #endif #ifdef HAVE_ERROR_CHECKING /* Because the PARAM system has not been initialized, temporarily * uncondtionally enable error checks. Once the PARAM system is * initialized, this may be reset */ MPIR_Process.do_error_checks = 1; #else MPIR_Process.do_error_checks = 0; #endif /* Initialize necessary subsystems and setup the predefined attribute * values. Subsystems may change these values. */ MPIR_Process.attrs.appnum = -1; MPIR_Process.attrs.host = MPI_PROC_NULL; MPIR_Process.attrs.io = MPI_PROC_NULL; MPIR_Process.attrs.lastusedcode = MPI_ERR_LASTCODE; MPIR_Process.attrs.universe = MPIR_UNIVERSE_SIZE_NOT_SET; MPIR_Process.attrs.wtime_is_global = 0; /* Set the functions used to duplicate attributes. These are * when the first corresponding keyval is created */ MPIR_Process.attr_dup = 0; MPIR_Process.attr_free = 0; #ifdef HAVE_CXX_BINDING /* Set the functions used to call functions in the C++ binding * for reductions and attribute operations. These are null * until a C++ operation is defined. This allows the C code * that implements these operations to not invoke a C++ code * directly, which may force the inclusion of symbols known only * to the C++ compiler (e.g., under more non-GNU compilers, including * Solaris and IRIX). */ MPIR_Process.cxx_call_op_fn = 0; #endif #ifdef HAVE_F08_BINDING MPIR_C_MPI_UNWEIGHTED = MPI_UNWEIGHTED; MPIR_C_MPI_WEIGHTS_EMPTY = MPI_WEIGHTS_EMPTY; #endif /* This allows the device to select an alternative function for * dimsCreate */ MPIR_Process.dimsCreate = 0; /* "Allocate" from the reserved space for builtin communicators and * (partially) initialize predefined communicators. comm_parent is * intially NULL and will be allocated by the device if the process group * was started using one of the MPI_Comm_spawn functions. */ MPIR_Process.comm_world = MPIR_Comm_builtin + 0; MPII_Comm_init(MPIR_Process.comm_world); MPIR_Process.comm_world->handle = MPI_COMM_WORLD; MPIR_Process.comm_world->context_id = 0 << MPIR_CONTEXT_PREFIX_SHIFT; MPIR_Process.comm_world->recvcontext_id = 0 << MPIR_CONTEXT_PREFIX_SHIFT; MPIR_Process.comm_world->comm_kind = MPIR_COMM_KIND__INTRACOMM; /* This initialization of the comm name could be done only when * comm_get_name is called */ MPL_strncpy(MPIR_Process.comm_world->name, "MPI_COMM_WORLD", MPI_MAX_OBJECT_NAME); MPIR_Process.comm_self = MPIR_Comm_builtin + 1; MPII_Comm_init(MPIR_Process.comm_self); MPIR_Process.comm_self->handle = MPI_COMM_SELF; MPIR_Process.comm_self->context_id = 1 << MPIR_CONTEXT_PREFIX_SHIFT; MPIR_Process.comm_self->recvcontext_id = 1 << MPIR_CONTEXT_PREFIX_SHIFT; MPIR_Process.comm_self->comm_kind = MPIR_COMM_KIND__INTRACOMM; MPL_strncpy(MPIR_Process.comm_self->name, "MPI_COMM_SELF", MPI_MAX_OBJECT_NAME); #ifdef MPID_NEEDS_ICOMM_WORLD MPIR_Process.icomm_world = MPIR_Comm_builtin + 2; MPII_Comm_init(MPIR_Process.icomm_world); MPIR_Process.icomm_world->handle = MPIR_ICOMM_WORLD; MPIR_Process.icomm_world->context_id = 2 << MPIR_CONTEXT_PREFIX_SHIFT; MPIR_Process.icomm_world->recvcontext_id = 2 << MPIR_CONTEXT_PREFIX_SHIFT; MPIR_Process.icomm_world->comm_kind = MPIR_COMM_KIND__INTRACOMM; MPL_strncpy(MPIR_Process.icomm_world->name, "MPI_ICOMM_WORLD", MPI_MAX_OBJECT_NAME); /* Note that these communicators are not ready for use - MPID_Init * will setup self and world, and icomm_world if it desires it. */ #endif MPIR_Process.comm_parent = NULL; /* Setup the initial communicator list in case we have * enabled the debugger message-queue interface */ MPII_COMML_REMEMBER(MPIR_Process.comm_world); MPII_COMML_REMEMBER(MPIR_Process.comm_self); /* MPIU_Timer_pre_init(); */ /* Wait for debugger to attach if requested. */ if (MPIR_CVAR_DEBUG_HOLD) { volatile int hold = 1; while (hold) #ifdef HAVE_USLEEP usleep(100); #endif ; } #if defined(HAVE_ERROR_CHECKING) && (HAVE_ERROR_CHECKING == MPID_ERROR_LEVEL_RUNTIME) MPIR_Process.do_error_checks = MPIR_CVAR_ERROR_CHECKING; #endif /* define MPI as initialized so that we can use MPI functions within * MPID_Init if necessary */ OPA_store_int(&MPIR_Process.mpich_state, MPICH_MPI_STATE__IN_INIT); /* We can't acquire any critical sections until this point. Any * earlier the basic data structures haven't been initialized */ MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); exit_init_cs_on_failure = 1; /* create MPI_INFO_NULL object */ /* FIXME: Currently this info object is empty, we need to add data to this * as defined by the standard. */ info_ptr = MPIR_Info_builtin + 1; info_ptr->handle = MPI_INFO_ENV; MPIR_Object_set_ref(info_ptr, 1); info_ptr->next = NULL; info_ptr->key = NULL; info_ptr->value = NULL; #ifdef USE_MEMORY_TRACING MPL_trinit(); #endif /* Set the number of tag bits. The device may override this value. */ MPIR_Process.tag_bits = MPIR_TAG_BITS_DEFAULT; /* Create complete request to return in the event of immediately complete * operations. Use a SEND request to cover all possible use-cases. */ MPIR_Process.lw_req = MPIR_Request_create(MPIR_REQUEST_KIND__SEND); MPIR_ERR_CHKANDSTMT(MPIR_Process.lw_req == NULL, mpi_errno, MPIX_ERR_NOREQ, goto fn_fail, "**nomemreq"); MPIR_cc_set(&MPIR_Process.lw_req->cc, 0); mpi_errno = MPID_Init(argc, argv, required, &thread_provided, &has_args, &has_env); if (mpi_errno) MPIR_ERR_POP(mpi_errno); /* Initialize collectives infrastructure */ mpi_errno = MPII_Coll_init(); if (mpi_errno) MPIR_ERR_POP(mpi_errno); /* Set tag_ub as function of tag_bits set by the device */ MPIR_Process.attrs.tag_ub = MPIR_TAG_USABLE_BITS; /* Assert: tag_ub should be a power of 2 minus 1 */ MPIR_Assert(((unsigned) MPIR_Process. attrs.tag_ub & ((unsigned) MPIR_Process.attrs.tag_ub + 1)) == 0); /* Assert: tag_ub is at least the minimum asked for in the MPI spec */ MPIR_Assert(MPIR_Process.attrs.tag_ub >= 32767); /* Capture the level of thread support provided */ MPIR_ThreadInfo.thread_provided = thread_provided; if (provided) *provided = thread_provided; #if defined MPICH_IS_THREADED MPIR_ThreadInfo.isThreaded = (thread_provided == MPI_THREAD_MULTIPLE); #endif /* MPICH_IS_THREADED */ /* FIXME: Define these in the interface. Does Timer init belong here? */ MPII_Timer_init(MPIR_Process.comm_world->rank, MPIR_Process.comm_world->local_size); #ifdef USE_MEMORY_TRACING #ifdef MPICH_IS_THREADED MPL_trconfig(MPIR_Process.comm_world->rank, MPIR_ThreadInfo.isThreaded); #else MPL_trconfig(MPIR_Process.comm_world->rank, 0); #endif /* Indicate that we are near the end of the init step; memory * allocated already will have an id of zero; this helps * separate memory leaks in the initialization code from * leaks in the "active" code */ #endif #ifdef MPL_USE_DBG_LOGGING /* FIXME: This is a hack to handle the common case of two worlds. * If the parent comm is not NULL, we always give the world number * as "1" (false). */ #ifdef MPICH_IS_THREADED MPL_dbg_init(argc, argv, has_args, has_env, MPIR_Process.comm_parent != NULL, MPIR_Process.comm_world->rank, MPIR_ThreadInfo.isThreaded); #else MPL_dbg_init(argc, argv, has_args, has_env, MPIR_Process.comm_parent != NULL, MPIR_Process.comm_world->rank, 0); #endif MPIR_DBG_INIT = MPL_dbg_class_alloc("INIT", "init"); MPIR_DBG_PT2PT = MPL_dbg_class_alloc("PT2PT", "pt2pt"); MPIR_DBG_THREAD = MPL_dbg_class_alloc("THREAD", "thread"); MPIR_DBG_DATATYPE = MPL_dbg_class_alloc("DATATYPE", "datatype"); MPIR_DBG_HANDLE = MPL_dbg_class_alloc("HANDLE", "handle"); MPIR_DBG_COMM = MPL_dbg_class_alloc("COMM", "comm"); MPIR_DBG_BSEND = MPL_dbg_class_alloc("BSEND", "bsend"); MPIR_DBG_ERRHAND = MPL_dbg_class_alloc("ERRHAND", "errhand"); MPIR_DBG_OTHER = MPL_dbg_class_alloc("OTHER", "other"); MPIR_DBG_REQUEST = MPL_dbg_class_alloc("REQUEST", "request"); MPIR_DBG_COLL = MPL_dbg_class_alloc("COLL", "coll"); MPIR_DBG_ASSERT = MPL_dbg_class_alloc("ASSERT", "assert"); MPIR_DBG_STRING = MPL_dbg_class_alloc("STRING", "string"); #endif /* Initialize the C versions of the Fortran link-time constants. * * We now initialize the Fortran symbols from within the Fortran * interface in the routine that first needs the symbols. * This fixes a problem with symbols added by a Fortran compiler that * are not part of the C runtime environment (the Portland group * compilers would do this) */ #if defined(HAVE_FORTRAN_BINDING) && defined(HAVE_MPI_F_INIT_WORKS_WITH_C) mpirinitf_(); #endif /* FIXME: Does this need to come before the call to MPID_InitComplete? * For some debugger support, MPII_Wait_for_debugger may want to use * MPI communication routines to collect information for the debugger */ #ifdef HAVE_DEBUGGER_SUPPORT MPII_Wait_for_debugger(); #endif /* Let the device know that the rest of the init process is completed */ if (mpi_errno == MPI_SUCCESS) mpi_errno = MPID_InitCompleted(); MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); /* Make fields of MPIR_Process global visible and set mpich_state * atomically so that MPI_Initialized() etc. are thread safe */ OPA_write_barrier(); OPA_store_int(&MPIR_Process.mpich_state, MPICH_MPI_STATE__POST_INIT); return mpi_errno; fn_fail: /* --BEGIN ERROR HANDLING-- */ /* signal to error handling routines that core services are unavailable */ OPA_store_int(&MPIR_Process.mpich_state, MPICH_MPI_STATE__PRE_INIT); if (exit_init_cs_on_failure) { MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX); } #if defined(MPICH_IS_THREADED) if (cs_initialized) { MPIR_Thread_CS_Finalize(); } #endif return mpi_errno; /* --END ERROR HANDLING-- */ }