From 8e2f697c66376dbce61bf8c762be91888af8b58c Mon Sep 17 00:00:00 2001 From: Hans Pabst Date: Mon, 20 Oct 2025 13:28:20 +0200 Subject: [PATCH] Get the number of distributed systems - Removed unused mp_get_node_global_rank routine. - Determine and print node count. - Improved output format. --- src/environment.F | 77 ++++++++++++++------------- src/mpiwrap/message_passing.F | 98 +++++++++++------------------------ 2 files changed, 72 insertions(+), 103 deletions(-) diff --git a/src/environment.F b/src/environment.F index f09c930105..363f52fed6 100644 --- a/src/environment.F +++ b/src/environment.F @@ -249,7 +249,7 @@ CONTAINS ! ************************************************************************************************** SUBROUTINE echo_all_hosts(para_env, output_unit) TYPE(mp_para_env_type), POINTER :: para_env - INTEGER :: output_unit + INTEGER, INTENT(IN) :: output_unit CHARACTER(LEN=default_string_length) :: string INTEGER :: ipe @@ -258,17 +258,15 @@ CONTAINS ! Print a list of all started processes - ALLOCATE (all_pid(para_env%num_pe)) - all_pid(:) = 0 + ALLOCATE (all_pid(para_env%num_pe), SOURCE=0) all_pid(para_env%mepos + 1) = r_pid CALL para_env%sum(all_pid) - ALLOCATE (all_host(30, para_env%num_pe)) - all_host(:, :) = 0 + ALLOCATE (all_host(30, para_env%num_pe), SOURCE=0) + CALL string_to_ascii(r_host_name, all_host(:, para_env%mepos + 1)) CALL para_env%sum(all_host) IF (output_unit > 0) THEN - WRITE (UNIT=output_unit, FMT="(T2,A)") "" DO ipe = 1, para_env%num_pe CALL ascii_to_string(all_host(:, ipe), string) @@ -276,8 +274,8 @@ CONTAINS TRIM(r_user_name)//"@"//TRIM(string)// & " has created rank and process ", ipe - 1, all_pid(ipe) END DO - WRITE (UNIT=output_unit, FMT="(T2,A)") "" END IF + DEALLOCATE (all_pid) DEALLOCATE (all_host) @@ -287,52 +285,54 @@ CONTAINS !> \brief echoes the list the number of process per host !> \param para_env ... !> \param output_unit ... +!> \param node_count Count number of distributed systems (nodes) ! ************************************************************************************************** - SUBROUTINE echo_all_process_host(para_env, output_unit) + SUBROUTINE echo_all_process_host(para_env, output_unit, node_count) TYPE(mp_para_env_type), POINTER :: para_env - INTEGER :: output_unit + INTEGER, INTENT(IN) :: output_unit + INTEGER, INTENT(OUT), OPTIONAL :: node_count CHARACTER(LEN=default_string_length) :: string, string_sec - INTEGER :: ipe, jpe, nr_occu + INTEGER :: ipe, jpe, nr_dist, nr_occu INTEGER, ALLOCATABLE, DIMENSION(:) :: all_pid INTEGER, ALLOCATABLE, DIMENSION(:, :) :: all_host - ALLOCATE (all_host(30, para_env%num_pe)) - all_host(:, :) = 0 + ALLOCATE (all_host(30, para_env%num_pe), SOURCE=0) + ALLOCATE (all_pid(para_env%num_pe), SOURCE=0) IF (m_procrun(r_pid) .EQ. 1) THEN CALL string_to_ascii(r_host_name, all_host(:, para_env%mepos + 1)) CALL para_env%sum(all_host) END IF - IF (output_unit > 0) THEN - ALLOCATE (all_pid(para_env%num_pe)) - all_pid(:) = 0 - - WRITE (UNIT=output_unit, FMT="(T2,A)") "" - DO ipe = 1, para_env%num_pe - nr_occu = 0 - IF (all_pid(ipe) .NE. -1) THEN - CALL ascii_to_string(all_host(:, ipe), string) - DO jpe = 1, para_env%num_pe - CALL ascii_to_string(all_host(:, jpe), string_sec) - IF (string .EQ. string_sec) THEN - nr_occu = nr_occu + 1 - all_pid(jpe) = -1 - END IF - END DO + nr_dist = 0 + IF (output_unit > 0) WRITE (UNIT=output_unit, FMT="(T2,A)") "" + DO ipe = 1, para_env%num_pe + nr_occu = 0 + IF (all_pid(ipe) .NE. -1) THEN + CALL ascii_to_string(all_host(:, ipe), string) + DO jpe = 1, para_env%num_pe + CALL ascii_to_string(all_host(:, jpe), string_sec) + IF (string .EQ. string_sec) THEN + nr_occu = nr_occu + 1 + all_pid(jpe) = -1 + END IF + END DO + IF (output_unit > 0) THEN WRITE (UNIT=output_unit, FMT="(T2,A,T63,I8,A)") & TRIM(r_user_name)//"@"//TRIM(string)// & " is running ", nr_occu, " processes" - WRITE (UNIT=output_unit, FMT="(T2,A)") "" END IF - END DO - DEALLOCATE (all_pid) - - END IF + nr_dist = nr_dist + 1 + END IF + END DO + DEALLOCATE (all_pid) DEALLOCATE (all_host) + CPASSERT(0 .LT. nr_dist) + IF (PRESENT(node_count)) node_count = nr_dist + END SUBROUTINE echo_all_process_host ! ************************************************************************************************** @@ -519,8 +519,8 @@ CONTAINS CHARACTER(LEN=default_string_length), & DIMENSION(:), POINTER :: trace_routines INTEGER :: cpuid, cpuid_static, i_cholesky, i_dgemm, i_diag, i_fft, i_grid_backend, & - iforce_eval, method_name_id, n_rep_val, nforce_eval, num_threads, output_unit, & - print_level, trace_max, unit_nr + iforce_eval, method_name_id, n_rep_val, nforce_eval, node_count, num_threads, & + output_unit, print_level, trace_max, unit_nr INTEGER(kind=int_8) :: Buffers, Buffers_avr, Buffers_max, Buffers_min, Cached, Cached_avr, & Cached_max, Cached_min, MemFree, MemFree_avr, MemFree_max, MemFree_min, MemLikelyFree, & MemLikelyFree_avr, MemLikelyFree_max, MemLikelyFree_min, MemTotal, MemTotal_avr, & @@ -739,12 +739,15 @@ CONTAINS SReclaimable = SReclaimable/1024 MemLikelyFree = MemLikelyFree/1024 + node_count = 1 ! Print a list of all started processes IF (do_echo_all_hosts) THEN CALL echo_all_hosts(para_env, output_unit) ! Print the number of processes per host - CALL echo_all_process_host(para_env, output_unit) + CALL echo_all_process_host(para_env, output_unit, node_count) + ELSE ! no echo + CALL echo_all_process_host(para_env, 0, node_count) END IF num_threads = 1 @@ -918,6 +921,8 @@ CONTAINS WRITE (UNIT=output_unit, FMT="(T2,A,T75,I6)") & start_section_label//"| Total number of message passing processes", & para_env%num_pe, & + start_section_label//"| Number of distributed systems (nodes)", & + node_count, & start_section_label//"| Number of threads for this process", & num_threads, & start_section_label//"| This output is from process", para_env%mepos diff --git a/src/mpiwrap/message_passing.F b/src/mpiwrap/message_passing.F index 892b6b6538..857c9e058a 100644 --- a/src/mpiwrap/message_passing.F +++ b/src/mpiwrap/message_passing.F @@ -836,7 +836,6 @@ MODULE message_passing ! informational / generation of sub comms PUBLIC :: mp_dims_create PUBLIC :: cp2k_is_parallel - PUBLIC :: mp_get_node_global_rank ! message passing PUBLIC :: mp_waitall, mp_waitany @@ -1231,7 +1230,7 @@ CONTAINS CHARACTER(LEN=default_string_length) :: debug_comm_count_char #if defined(__parallel) - INTEGER :: ierr + INTEGER :: ierr CALL mpi_barrier(MPI_COMM_WORLD, ierr) ! call mpi directly to avoid 0 stack pointer #endif CALL rm_mp_perf_env() @@ -1284,15 +1283,15 @@ CONTAINS !> this function is private to message_passing.F ! ************************************************************************************************** SUBROUTINE mp_stop(ierr, prg_code) - INTEGER, INTENT(IN) :: ierr - CHARACTER(LEN=*), INTENT(IN) :: prg_code + INTEGER, INTENT(IN) :: ierr + CHARACTER(LEN=*), INTENT(IN) :: prg_code #if defined(__parallel) - INTEGER :: istat, len - CHARACTER(LEN=MPI_MAX_ERROR_STRING) :: error_string + INTEGER :: istat, len + CHARACTER(LEN=MPI_MAX_ERROR_STRING) :: error_string CHARACTER(LEN=MPI_MAX_ERROR_STRING + 512) :: full_error #else - CHARACTER(LEN=512) :: full_error + CHARACTER(LEN=512) :: full_error #endif #if defined(__parallel) @@ -1337,8 +1336,8 @@ CONTAINS !> \param request ... ! ************************************************************************************************** SUBROUTINE mp_isync(comm, request) - CLASS(mp_comm_type), INTENT(IN) :: comm - TYPE(mp_request_type), INTENT(OUT) :: request + CLASS(mp_comm_type), INTENT(IN) :: comm + TYPE(mp_request_type), INTENT(OUT) :: request CHARACTER(len=*), PARAMETER :: routineN = 'mp_isync' @@ -1367,7 +1366,7 @@ CONTAINS SUBROUTINE mp_comm_rank(taskid, comm) INTEGER, INTENT(OUT) :: taskid - CLASS(mp_comm_type), INTENT(IN) :: comm + CLASS(mp_comm_type), INTENT(IN) :: comm CHARACTER(len=*), PARAMETER :: routineN = 'mp_comm_rank' @@ -1430,8 +1429,8 @@ CONTAINS SUBROUTINE mp_cart_get(comm, dims, task_coor, periods) CLASS(mp_cart_type), INTENT(IN) :: comm - INTEGER, INTENT(OUT), OPTIONAL :: dims(comm%ndims), task_coor(comm%ndims) - LOGICAL, INTENT(out), OPTIONAL :: periods(comm%ndims) + INTEGER, INTENT(OUT), OPTIONAL :: dims(comm%ndims), task_coor(comm%ndims) + LOGICAL, INTENT(out), OPTIONAL :: periods(comm%ndims) CHARACTER(len=*), PARAMETER :: routineN = 'mp_cart_get' @@ -1559,8 +1558,8 @@ CONTAINS ! ************************************************************************************************** FUNCTION mp_comm_compare(comm1, comm2) RESULT(res) - CLASS(mp_comm_type), INTENT(IN) :: comm1, comm2 - INTEGER :: res + CLASS(mp_comm_type), INTENT(IN) :: comm1, comm2 + INTEGER :: res CHARACTER(len=*), PARAMETER :: routineN = 'mp_comm_compare' @@ -1637,7 +1636,7 @@ CONTAINS ! ************************************************************************************************** SUBROUTINE mp_comm_free(comm) - CLASS(mp_comm_type), INTENT(INOUT) :: comm + CLASS(mp_comm_type), INTENT(INOUT) :: comm CHARACTER(len=*), PARAMETER :: routineN = 'mp_comm_free' @@ -1741,8 +1740,8 @@ CONTAINS ! ************************************************************************************************** SUBROUTINE mp_comm_dup(comm1, comm2) - CLASS(mp_comm_type), INTENT(IN) :: comm1 - CLASS(mp_comm_type), INTENT(OUT) :: comm2 + CLASS(mp_comm_type), INTENT(IN) :: comm1 + CLASS(mp_comm_type), INTENT(OUT) :: comm2 CHARACTER(len=*), PARAMETER :: routineN = 'mp_comm_dup' @@ -1848,7 +1847,7 @@ CONTAINS ! ************************************************************************************************** SUBROUTINE mp_para_env_create(para_env, group) TYPE(mp_para_env_type), POINTER :: para_env - CLASS(mp_comm_type), INTENT(in) :: group + CLASS(mp_comm_type), INTENT(in) :: group IF (ASSOCIATED(para_env)) & CPABORT("The passed para_env must not be associated!") @@ -1885,8 +1884,8 @@ CONTAINS !> \author fawzi ! ************************************************************************************************** SUBROUTINE mp_para_cart_create(cart, group) - TYPE(mp_para_cart_type), POINTER, INTENT(OUT) :: cart - CLASS(mp_comm_type), INTENT(in) :: group + TYPE(mp_para_cart_type), POINTER, INTENT(OUT) :: cart + CLASS(mp_comm_type), INTENT(in) :: group IF (ASSOCIATED(cart)) & CPABORT("The passed para_cart must not be associated!") @@ -2006,7 +2005,7 @@ CONTAINS !> \param rank ... ! ************************************************************************************************** SUBROUTINE mp_cart_rank(comm, pos, rank) - CLASS(mp_cart_type), INTENT(IN) :: comm + CLASS(mp_cart_type), INTENT(IN) :: comm INTEGER, DIMENSION(:), INTENT(IN) :: pos INTEGER, INTENT(OUT) :: rank @@ -2041,7 +2040,7 @@ CONTAINS !> see isendrecv ! ************************************************************************************************** SUBROUTINE mp_wait(request) - CLASS(mp_request_type), INTENT(inout) :: request + CLASS(mp_request_type), INTENT(inout) :: request CHARACTER(len=*), PARAMETER :: routineN = 'mp_wait' @@ -2161,16 +2160,16 @@ CONTAINS ! ************************************************************************************************** #if defined(__parallel) SUBROUTINE mpi_waitall_internal(count, array_of_requests, array_of_statuses, ierr) - INTEGER, INTENT(in) :: count - TYPE(mp_request_type), DIMENSION(count), INTENT(inout) :: array_of_requests + INTEGER, INTENT(in) :: count + TYPE(mp_request_type), DIMENSION(count), INTENT(inout) :: array_of_requests #if !defined(__MPI_F08) INTEGER, DIMENSION(MPI_STATUS_SIZE, count), & - INTENT(out) :: array_of_statuses + INTENT(out) :: array_of_statuses #else TYPE(MPI_Status), DIMENSION(count), & - INTENT(out) :: array_of_statuses + INTENT(out) :: array_of_statuses #endif - INTEGER, INTENT(out) :: ierr + INTEGER, INTENT(out) :: ierr INTEGER :: i MPI_REQUEST_TYPE, ALLOCATABLE, DIMENSION(:) :: request_handles @@ -2275,7 +2274,7 @@ CONTAINS !> \author Nico Holmberg ! ************************************************************************************************** FUNCTION mp_test_1(request) RESULT(flag) - CLASS(mp_request_type), INTENT(inout) :: request + CLASS(mp_request_type), INTENT(inout) :: request LOGICAL :: flag #if defined(__parallel) @@ -2400,8 +2399,8 @@ CONTAINS !> \author Joost VandeVondele ! ************************************************************************************************** SUBROUTINE mp_comm_split_direct(comm, sub_comm, color, key) - CLASS(mp_comm_type), INTENT(in) :: comm - CLASS(mp_comm_type), INTENT(OUT) :: sub_comm + CLASS(mp_comm_type), INTENT(in) :: comm + CLASS(mp_comm_type), INTENT(OUT) :: sub_comm INTEGER, INTENT(in) :: color INTEGER, INTENT(in), OPTIONAL :: key @@ -2562,41 +2561,6 @@ CONTAINS END SUBROUTINE mp_comm_split -! ************************************************************************************************** -!> \brief Get the local rank on the node according to the global communicator -!> \return Node Rank id -!> \author Alfio Lazzaro -! ************************************************************************************************** - FUNCTION mp_get_node_global_rank() & - RESULT(node_rank) - - INTEGER :: node_rank - - CHARACTER(len=*), PARAMETER :: routineN = 'mp_get_node_global_rank' - INTEGER :: handle -#if defined(__parallel) - INTEGER :: ierr, rank - TYPE(mp_comm_type) :: comm -#endif - - CALL mp_timeset(routineN, handle) - -#if defined(__parallel) - CALL mpi_comm_rank(MPI_COMM_WORLD, rank, ierr) - IF (ierr /= mpi_success) CALL mp_stop(ierr, routineN) - CALL mpi_comm_split_type(MPI_COMM_WORLD, MPI_COMM_TYPE_SHARED, rank, MPI_INFO_NULL, comm%handle, ierr) - IF (ierr /= mpi_success) CALL mp_stop(ierr, routineN) - CALL mpi_comm_rank(comm%handle, node_rank, ierr) - IF (ierr /= mpi_success) CALL mp_stop(ierr, routineN) - CALL mpi_comm_free(comm%handle, ierr) - IF (ierr /= mpi_success) CALL mp_stop(ierr, routineN) -#else - node_rank = 0 -#endif - CALL mp_timestop(handle) - - END FUNCTION mp_get_node_global_rank - ! ************************************************************************************************** !> \brief probes for an incoming message with any tag !> \param[inout] source the source of the possible incoming message, @@ -2609,8 +2573,8 @@ CONTAINS !> \author Mandes ! ************************************************************************************************** SUBROUTINE mp_probe(source, comm, tag) - INTEGER, INTENT(INOUT) :: source - CLASS(mp_comm_type), INTENT(IN) :: comm + INTEGER, INTENT(INOUT) :: source + CLASS(mp_comm_type), INTENT(IN) :: comm INTEGER, INTENT(OUT) :: tag CHARACTER(len=*), PARAMETER :: routineN = 'mp_probe'