diff --git a/CMakeLists.txt b/CMakeLists.txt index 9ce5af9cf..1a9ed99c0 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -28,10 +28,12 @@ IF(NOT CMAKE_Fortran_COMPILER_SUPPORTS_F90) ENDIF(NOT CMAKE_Fortran_COMPILER_SUPPORTS_F90) # Set some options the user may choose -# Uncomment the below if you want the user to choose a parallelization library -OPTION(USE_MPI "Use the MPI library for parallelization" ON) +OPTION(USE_COARRAY "Use Coarray Fortran for parallelization of test particles" OFF) OPTION(USE_OPENMP "Use OpenMP for parallelization" ON) +IF (USE_COARRAY) + ADD_DEFINITIONS(-DCOARRAY) +ENDIF() # Locate and set parallelization libraries. There are some CMake peculiarities # taken care of here, such as the fact that the FindOpenMP routine doesn't know diff --git a/cmake/Modules/FindCoarray_Fortran.cmake b/cmake/Modules/FindCoarray_Fortran.cmake new file mode 100644 index 000000000..314371326 --- /dev/null +++ b/cmake/Modules/FindCoarray_Fortran.cmake @@ -0,0 +1,104 @@ +# Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh +# This file is part of Swiftest. +# Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License +# as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. +# Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty +# of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. +# You should have received a copy of the GNU General Public License along with Swiftest. +# If not, see: https://www.gnu.org/licenses. + +# - Finds Coarray support +# This module can be used to detect Coarray support in a compiler. +# If the compiler supports Coarray, the flags required to compile with +# coarray support are set. +# +# This module was modified from the standard FindOpenMP module to find Fortran +# flags. +# +# The following variables are set: +# Coarray_Fortran_FLAGS - flags to add to the Fortran compiler for Coarray +# support. In general, you must use these at both +# compile- and link-time. +# OMP_NUM_PROCS - the max number of processors available to Coarray + +#============================================================================= + +INCLUDE (${CMAKE_ROOT}/Modules/FindPackageHandleStandardArgs.cmake) + +STRING(TOUPPER "${CMAKE_BUILD_TYPE}" BT) +IF(BT STREQUAL "DEBUG") + SET (Coarray_Fortran_FLAG_CANDIDATES + #Intel + "-coarray=single" + #Intel windows + "/Qcoarray:single" + #Gnu + "-fcoarray=single" + #Empty, if compiler automatically accepts coarray + " " + ) +ELSE() + SET (Coarray_Fortran_FLAG_CANDIDATES + #Intel + "-coarray=distributed" + #Intel windows + "/Qcoarray:distributed" + #Gnu + "-fcoarray=lib -lcaf_mpi" + #Empty, if compiler automatically accepts coarray + " " + ) +ENDIF() + + +IF (DEFINED Coarray_Fortran_FLAGS) + SET (Coarray_Fortran_FLAG_CANDIDATES) +ENDIF (DEFINED Coarray_Fortran_FLAGS) + +# check fortran compiler. also determine number of processors +FOREACH (FLAG ${Coarray_Fortran_FLAG_CANDIDATES}) + SET (SAFE_CMAKE_REQUIRED_FLAGS "${CMAKE_REQUIRED_FLAGS}") + SET (CMAKE_REQUIRED_FLAGS "${FLAG}") + UNSET (Coarray_FLAG_DETECTED CACHE) + MESSAGE (STATUS "Try Coarray Fortran flag = [${FLAG}]") + FILE (WRITE "${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeTmp/testFortranCoarray.f90" +" +program TestCoarray + integer, codimension[*] :: i + write(*,'(I2)',ADVANCE='NO') num_images() +end program TestCoarray +") + SET (MACRO_CHECK_FUNCTION_DEFINITIONS + "-DCoarray_FLAG_DETECTED ${CMAKE_REQUIRED_FLAGS}") + TRY_RUN (Coarray_RUN_FAILED Coarray_FLAG_DETECTED ${CMAKE_BINARY_DIR} + ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeTmp/testFortranCoarray.f90 + COMPILE_DEFINITIONS ${CMAKE_REQUIRED_DEFINITIONS} + CMAKE_FLAGS -DCOMPILE_DEFINITIONS:STRING=${MACRO_CHECK_FUNCTION_DEFINITIONS} + COMPILE_OUTPUT_VARIABLE OUTPUT + RUN_OUTPUT_VARIABLE OMP_NUM_PROCS_INTERNAL) + IF (Coarray_FLAG_DETECTED) + FILE (APPEND ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeOutput.log + "Determining if the Fortran compiler supports Coarray passed with " + "the following output:\n${OUTPUT}\n\n") + SET (Coarray_FLAG_DETECTED 1) + IF (Coarray_RUN_FAILED) + MESSAGE (FATAL_ERROR "Coarray found, but test code did not run") + ENDIF (Coarray_RUN_FAILED) + SET (Coarray_Fortran_FLAGS_INTERNAL "${FLAG}") + BREAK () + ELSE () + FILE (APPEND ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeError.log + "Determining if the Fortran compiler supports Coarray failed with " + "the following output:\n${OUTPUT}\n\n") + SET (Coarray_FLAG_DETECTED 0) + ENDIF (Coarray_FLAG_DETECTED) +ENDFOREACH (FLAG ${Coarray_Fortran_FLAG_CANDIDATES}) + +SET (Coarray_Fortran_FLAGS "${Coarray_Fortran_FLAGS_INTERNAL}" + CACHE STRING "Fortran compiler flags for Coarray parallization") + +# handle the standard arguments for FIND_PACKAGE +FIND_PACKAGE_HANDLE_STANDARD_ARGS (Coarray_Fortran DEFAULT_MSG + Coarray_Fortran_FLAGS) + +MARK_AS_ADVANCED(Coarray_Fortran_FLAGS) diff --git a/cmake/Modules/SetFortranFlags.cmake b/cmake/Modules/SetFortranFlags.cmake index 97009a25e..403bc6ed0 100644 --- a/cmake/Modules/SetFortranFlags.cmake +++ b/cmake/Modules/SetFortranFlags.cmake @@ -79,9 +79,9 @@ SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS}" Fortran "-xhost" # Intel "/QxHost" # Intel Windows ${GNUNATIVE} # GNU - "-ta=host" # Portland Group ) + ################### ### DEBUG FLAGS ### ################### @@ -99,12 +99,11 @@ SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG}" Fortran "-warn all" # Intel "/warn:all" # Intel Windows "-Wall" # GNU - # Portland Group (on by default) ) # Traceback SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG}" - Fortran "-traceback" # Intel/Portland Group + Fortran "-traceback" # Intel Group "/traceback" # Intel Windows "-fbacktrace" # GNU (gfortran) "-ftrace=full" # GNU (g95) @@ -233,7 +232,6 @@ SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE}" Fortran "-unroll" # Intel "/unroll" # Intel Windows "-funroll-loops" # GNU - "-Munroll" # Portland Group ) # Inline functions @@ -241,7 +239,6 @@ SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE}" Fortran "-inline" # Intel "/Qinline" # Intel Windows "-finline-functions" # GNU - "-Minline" # Portland Group ) @@ -323,9 +320,9 @@ SET_COMPILE_FLAG(FASTMATH_FLAGS "${FASTMATH_FLAGS}" ##################### # Enables the optimization reports to be generated SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS_PROFILE "${CMAKE_Fortran_FLAGS_RELEASE}" - Fortran "-pg -qopt-report=5 -traceback -p -g3" # Intel - "/Qopt-report:5 /traceback -g3" # Windows Intel - "-pg -fbacktrace" + Fortran "-O2 -pg -qopt-report=5 -traceback -p -g3" # Intel + "/O2 /Qopt-report:5 /traceback -g3" # Windows Intel + "-O2 -pg -fbacktrace" ) # Sanitize diff --git a/cmake/Modules/SetParallelizationLibrary.cmake b/cmake/Modules/SetParallelizationLibrary.cmake index 224806406..505a77d62 100644 --- a/cmake/Modules/SetParallelizationLibrary.cmake +++ b/cmake/Modules/SetParallelizationLibrary.cmake @@ -7,11 +7,6 @@ # You should have received a copy of the GNU General Public License along with Swiftest. # If not, see: https://www.gnu.org/licenses. -# Turns on either OpenMP or MPI -# If both are requested, the other is disabled -# When one is turned on, the other is turned off -# If both are off, we explicitly disable them just in case - IF (USE_OPENMP) # Find OpenMP IF (NOT OpenMP_Fortran_FLAGS) @@ -20,23 +15,22 @@ IF (USE_OPENMP) MESSAGE (FATAL_ERROR "Fortran compiler does not support OpenMP") ENDIF (NOT OpenMP_Fortran_FLAGS) ENDIF (NOT OpenMP_Fortran_FLAGS) - # Turn of MPI ENDIF (USE_OPENMP) -IF (USE_MPI) - # Find MPI - IF (NOT MPI_Fortran_FOUND) - FIND_PACKAGE (MPI REQUIRED) - ENDIF (NOT MPI_Fortran_FOUND) -ENDIF (USE_MPI) +IF (USE_COARRAY) + IF (NOT Coarray_Fortran_FLAGS) + FIND_PACKAGE (Coarray_Fortran) + IF (NOT Coarray_Fortran_FLAGS) + MESSAGE (FATAL_ERROR "Fortran compiler does not support Coarrays") + ENDIF (NOT Coarray_Fortran_FLAGS) + ENDIF (NOT Coarray_Fortran_FLAGS) +ENDIF (USE_COARRAY) -IF (NOT USE_OPENMP AND NOT USE_MPI) - # Turn off both OpenMP and MPI +IF (NOT USE_OPENMP AND NOT USE_COARRAY) + # Turn off both OpenMP and CAF SET (OMP_NUM_PROCS 0 CACHE STRING "Number of processors OpenMP may use" FORCE) UNSET (OpenMP_Fortran_FLAGS CACHE) + UNSET (Coarray_Fortran_FLAGS CACHE) UNSET (GOMP_Fortran_LINK_FLAGS CACHE) - UNSET (MPI_FOUND CACHE) - UNSET (MPI_COMPILER CACHE) - UNSET (MPI_LIBRARY CACHE) -ENDIF (NOT USE_OPENMP AND NOT USE_MPI) +ENDIF (NOT USE_OPENMP AND NOT USE_COARRAY) diff --git a/python/swiftest/swiftest/io.py b/python/swiftest/swiftest/io.py index 6a376d387..0c0007488 100644 --- a/python/swiftest/swiftest/io.py +++ b/python/swiftest/swiftest/io.py @@ -32,7 +32,8 @@ "ENCOUNTER_CHECK", "TSTART", "DUMP_CADENCE", - "ENCOUNTER_SAVE") + "ENCOUNTER_SAVE", + "COARRAY") # This list defines features that are booleans, so must be converted to/from string when writing/reading from file bool_param = ["RESTART", @@ -46,7 +47,8 @@ "ENERGY", "GR", "YARKOVSKY", - "YORP"] + "YORP", + "COARRAY"] int_param = ["ISTEP_OUT", "DUMP_CADENCE"] float_param = ["T0", "TSTART", "TSTOP", "DT", "CHK_RMIN", "CHK_RMAX", "CHK_EJECT", "CHK_QMIN", "DU2M", "MU2KG", @@ -59,7 +61,7 @@ # This defines Xarray Dataset variables that are strings, which must be processed due to quirks in how NetCDF-Fortran # handles strings differently than Python's Xarray. -string_varnames = ["name", "particle_type", "status", "origin_type", "stage", "regime"] +string_varnames = ["name", "particle_type", "origin_type", "stage", "regime"] char_varnames = ["space"] int_varnames = ["id", "ntp", "npl", "nplm", "discard_body_id", "collision_id", "status"] diff --git a/python/swiftest/swiftest/simulation_class.py b/python/swiftest/swiftest/simulation_class.py index 991758441..32171e72d 100644 --- a/python/swiftest/swiftest/simulation_class.py +++ b/python/swiftest/swiftest/simulation_class.py @@ -299,6 +299,11 @@ def __init__(self,read_param: bool = False, Parameter input file equivalent: `ENCOUNTER_CHECK` dask : bool, default False Use Dask to lazily load data (useful for very large datasets) + coarray : bool, default False + If true, will employ Coarrays on test particle structures to run in single program/multiple data parallel mode. + *Note" In order to use this capability, Swiftest must be compiled for Coarray support. Only certain integrators + can use Coarrays: RMVS, WHM, Helio are all compatible, but SyMBA is not, due to the way tp-pl close encounters + are handeled. verbose : bool, default True If set to True, then more information is printed by Simulation methods as they are executed. Setting to False suppresses most messages other than errors. @@ -824,6 +829,7 @@ def set_parameter(self, verbose: bool = True, **kwargs): "ephemeris_date": "MBCL", "restart": False, "encounter_save" : "NONE", + "coarray" : False, "simdir" : self.simdir } param_file = kwargs.pop("param_file",None) @@ -1065,6 +1071,7 @@ def set_feature(self, interaction_loops: Literal["TRIANGULAR", "FLAT"] | None = None, encounter_check_loops: Literal["TRIANGULAR", "SORTSWEEP"] | None = None, encounter_save: Literal["NONE", "TRAJECTORY", "CLOSEST", "BOTH"] | None = None, + coarray: bool | None = None, verbose: bool | None = None, simdir: str | os.PathLike = None, **kwargs: Any @@ -1130,6 +1137,11 @@ def set_feature(self, * "SORTSWEEP" : A Sort-Sweep algorithm is used to reduce the population of potential close encounter bodies. This algorithm is still in development, and does not necessarily speed up the encounter checking. Use with caution. + coarray : bool, default False + If true, will employ Coarrays on test particle structures to run in single program/multiple data parallel mode. + *Note" In order to use this capability, Swiftest must be compiled for Coarray support. Only certain integrators + can use Coarrays: RMVS, WHM, Helio are all compatible, but SyMBA is not, due to the way tp-pl close encounters + are handeled. tides: bool, optional Turns on tidal model (IN DEVELOPMENT - IGNORED) Yarkovsky: bool, optional @@ -1279,7 +1291,14 @@ def set_feature(self, self.driver_executable = self.binary_path / "swiftest_driver" self.param_file = Path(kwargs.pop("param_file","param.in")) + if coarray is not None: + if self.codename == "Swiftest": + self.param["COARRAY"] = coarray + update_list.append("coarray") + + self.param["TIDES"] = False + feature_dict = self.get_feature(update_list, verbose) return feature_dict @@ -1321,6 +1340,7 @@ def get_feature(self, arg_list: str | List[str] | None = None, verbose: bool | N "big_discard": "BIG_DISCARD", "interaction_loops": "INTERACTION_LOOPS", "encounter_check_loops": "ENCOUNTER_CHECK", + "coarray" : "COARRAY", "restart": "RESTART" } diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 1f657d65c..d2a04991c 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -83,11 +83,27 @@ SET(FAST_MATH_FILES ${SRC}/swiftest/swiftest_driver.f90 ) -set(SWIFTEST_src ${FAST_MATH_FILES} ${STRICT_MATH_FILES}) +SET(COARRAY_FILES + ${SRC}/coarray/coarray_module.f90 + ${SRC}/coarray/coarray_clone.f90 + ${SRC}/coarray/coarray_collect.f90 + ${SRC}/swiftest/swiftest_coarray.f90 + ${SRC}/whm/whm_coarray.f90 + ${SRC}/rmvs/rmvs_coarray.f90 +) + +IF(USE_COARRAY) + set(SWIFTEST_src ${COARRAY_FILES} ${FAST_MATH_FILES} ${STRICT_MATH_FILES}) +ELSE() + set(SWIFTEST_src ${FAST_MATH_FILES} ${STRICT_MATH_FILES}) +ENDIF(USE_COARRAY) # Define the executable in terms of the source files ADD_EXECUTABLE(${SWIFTEST_DRIVER} ${SWIFTEST_src}) +# Turn preprocessor on for all files +SET_SOURCE_FILES_PROPERTIES(${SWIFTEST_src} PROPERTIES Fortran_PREPROCESS ON) + ##################################################### # Add the needed libraries and special compiler flags ##################################################### @@ -99,14 +115,14 @@ IF(USE_OPENMP) SET_TARGET_PROPERTIES(${SWIFTEST_DRIVER} PROPERTIES COMPILE_FLAGS "${OpenMP_Fortran_FLAGS}" LINK_FLAGS "${OpenMP_Fortran_FLAGS}") -ELSEIF(USE_MPI) - SET_TARGET_PROPERTIES(${SWIFTEST_DRIVER} PROPERTIES - COMPILE_FLAGS "${MPI_Fortran_COMPILE_FLAGS}" - LINK_FLAGS "${MPI_Fortran_LINK_FLAGS}") - INCLUDE_DIRECTORIES(${MPI_Fortran_INCLUDE_PATH}) - TARGET_LINK_LIBRARIES(${SWIFTEST_DRIVER} ${MPI_Fortran_LIBRARIES}) ENDIF(USE_OPENMP) +IF(USE_COARRAY) + SET_TARGET_PROPERTIES(${SWIFTEST_DRIVER} PROPERTIES + COMPILE_FLAGS "${Coarray_Fortran_FLAGS}" + LINK_FLAGS "${Coarray_Fortran_FLAGS}") +ENDIF(USE_COARRAY) + ##################################### # Tell how to install this executable @@ -127,3 +143,8 @@ IF(BT STREQUAL "RELEASE" OR BT STREQUAL "PROFILE") SET_PROPERTY(SOURCE ${FAST_MATH_FILES} APPEND_STRING PROPERTY COMPILE_FLAGS "${FASTMATH_FLAGS}") ENDIF() +IF(BT STREQUAL "DEBUG") + ADD_DEFINITIONS(-DDEBUG) +ELSEIF(BT STREQUAL "PROFILE") + ADD_DEFINITIONS(-DPROFILE) +ENDIF() \ No newline at end of file diff --git a/src/base/base_module.f90 b/src/base/base_module.f90 index 0a9429dbc..01c111661 100644 --- a/src/base/base_module.f90 +++ b/src/base/base_module.f90 @@ -13,21 +13,28 @@ module base !! Base type definitions. This allows the collision and encounter modules to be defined before the swiftest module. !! use globals +#ifdef COARRAY + use coarray +#endif implicit none public - !> User defined parameters that are read in from the parameters input file. !> Each paramter is initialized to a default values. type, abstract :: base_parameters - character(len=:), allocatable :: integrator !! Name of the nbody integrator used - character(len=:), allocatable :: param_file_name !! The name of the parameter file + character(STRMAX) :: integrator !! Name of the nbody integrator used + character(STRMAX) :: param_file_name !! The name of the parameter file real(DP) :: t0 = 0.0_DP !! Integration reference time real(DP) :: tstart = -1.0_DP !! Integration start time real(DP) :: tstop = -1.0_DP !! Integration stop time real(DP) :: dt = -1.0_DP !! Time step integer(I8B) :: iloop = 0_I8B !! Main loop counter integer(I8B) :: nloops = 0_I8B !! Total number of loops to execute + integer(I8B) :: istart = 0_I8B !! Starting index for loop counter + integer(I4B) :: iout = 0 !! Output cadence counter + integer(I4B) :: idump = 0 !! Dump cadence counter + integer(I4B) :: nout = 0 !! Current output step + integer(I4B) :: istep = 0 !! Current value of istep (used for time stretching) character(STRMAX) :: incbfile = CB_INFILE !! Name of input file for the central body character(STRMAX) :: inplfile = PL_INFILE !! Name of input file for massive bodies character(STRMAX) :: intpfile = TP_INFILE !! Name of input file for test particles @@ -67,6 +74,7 @@ module base character(NAMELEN) :: interaction_loops = "ADAPTIVE" !! Method used to compute interaction loops. Options are "TRIANGULAR", "FLAT", or "ADAPTIVE" character(NAMELEN) :: encounter_check_plpl = "ADAPTIVE" !! Method used to compute pl-pl encounter checks. Options are "TRIANGULAR", "SORTSWEEP", or "ADAPTIVE" character(NAMELEN) :: encounter_check_pltp = "ADAPTIVE" !! Method used to compute pl-tp encounter checks. Options are "TRIANGULAR", "SORTSWEEP", or "ADAPTIVE" + logical :: lcoarray = .false. !! Use Coarrays for test particle parallelization. ! The following are used internally, and are not set by the user, but instead are determined by the input value of INTERACTION_LOOPS logical :: lflatten_interactions = .false. !! Use the flattened upper triangular matrix for pl-pl interaction loops @@ -97,9 +105,9 @@ module base logical :: lfirstkick = .true. !! Initiate the first kick in a symplectic step logical :: lrestart = .false. !! Indicates whether or not this is a restarted run - character(len=:), allocatable :: display_style !! Style of the output display {"STANDARD", "COMPACT"}). Default is "STANDARD" - integer(I4B) :: display_unit !! File unit number for display (either to stdout or to a log file) - logical :: log_output = .false. !! Logs the output to file instead of displaying it on the terminal + character(NAMELEN) :: display_style !! Style of the output display {"STANDARD", "COMPACT"}). Default is "STANDARD" + integer(I4B) :: display_unit !! File unit number for display (either to stdout or to a log file) + logical :: log_output = .false. !! Logs the output to file instead of displaying it on the terminal ! Future features not implemented or in development logical :: lgr = .false. !! Turn on GR @@ -111,6 +119,9 @@ module base procedure(abstract_io_param_reader), deferred :: reader procedure(abstract_io_param_writer), deferred :: writer procedure(abstract_io_read_in_param), deferred :: read_in +#ifdef COARRAY + procedure :: coclone => base_coclone_param +#endif end type base_parameters abstract interface @@ -206,14 +217,6 @@ end subroutine abstract_util_dealloc_object end interface - type, abstract, extends(base_object) :: base_multibody - integer(I4B) :: nbody = 0 !! Number of bodies - integer(I4B), dimension(:), allocatable :: id !! Identifier - contains - procedure :: dealloc => base_util_dealloc_multibody - end type base_multibody - - !> Class definition for the kinship relationships used in bookkeeping multiple collisions bodies in a single time step. type, abstract :: base_kinship end type base_kinship @@ -223,36 +226,308 @@ end subroutine abstract_util_dealloc_object type, abstract :: base_nbody_system end type base_nbody_system + + interface util_append + module procedure base_util_append_arr_char_string + module procedure base_util_append_arr_DP + module procedure base_util_append_arr_DPvec + module procedure base_util_append_arr_I4B + module procedure base_util_append_arr_logical + end interface + + interface util_fill + module procedure base_util_fill_arr_char_string + module procedure base_util_fill_arr_DP + module procedure base_util_fill_arr_DPvec + module procedure base_util_fill_arr_I4B + module procedure base_util_fill_arr_logical + end interface + + interface util_resize + module procedure base_util_resize_arr_char_string + module procedure base_util_resize_arr_DP + module procedure base_util_resize_arr_DPvec + module procedure base_util_resize_arr_I4B + module procedure base_util_resize_arr_logical + end interface + + interface util_sort + module procedure base_util_sort_i4b + module procedure base_util_sort_index_i4b + module procedure base_util_sort_index_I4B_I8Bind + module procedure base_util_sort_index_I8B_I8Bind + module procedure base_util_sort_sp + module procedure base_util_sort_index_sp + module procedure base_util_sort_dp + module procedure base_util_sort_index_dp + end interface + + interface util_sort_rearrange + module procedure base_util_sort_rearrange_arr_char_string + module procedure base_util_sort_rearrange_arr_DP + module procedure base_util_sort_rearrange_arr_DPvec + module procedure base_util_sort_rearrange_arr_I4B + module procedure base_util_sort_rearrange_arr_I4B_I8Bind + module procedure base_util_sort_rearrange_arr_logical + module procedure base_util_sort_rearrange_arr_logical_I8Bind + end interface + + interface util_spill + module procedure base_util_spill_arr_char_string + module procedure base_util_spill_arr_DP + module procedure base_util_spill_arr_DPvec + module procedure base_util_spill_arr_I4B + module procedure base_util_spill_arr_I8B + module procedure base_util_spill_arr_logical + end interface + + interface util_unique + module procedure base_util_unique_DP + module procedure base_util_unique_I4B + end interface + contains - subroutine base_util_copy_store(self, source) + subroutine base_util_append_arr_char_string(arr, source, nold, lsource_mask) !! author: David A. Minton !! - !! Stores a snapshot of the nbody system so that later it can be retrieved for saving to file. + !! Append a single array of character string type onto another. If the destination array is not allocated, or is not big enough, this will allocate space for it. implicit none - class(base_storage_frame), intent(inout) :: self !! Swiftest storage frame object - class(*), intent(in) :: source !! Swiftest n-body system object + ! Arguments + character(len=STRMAX), dimension(:), allocatable, intent(inout) :: arr !! Destination array + character(len=STRMAX), dimension(:), allocatable, intent(in) :: source !! Array to append + integer(I4B), intent(in), optional :: nold !! Extent of original array. If passed, the source array will begin at arr(nold+1). Otherwise, the size of arr will be used. + logical, dimension(:), intent(in), optional :: lsource_mask !! Logical mask indicating which elements to append to + ! Internals + integer(I4B) :: nnew, nsrc, nend_orig + + if (.not.allocated(source)) return + + if (present(lsource_mask)) then + nsrc = count(lsource_mask(:)) + else + nsrc = size(source) + end if + if (nsrc == 0) return + + if (.not.allocated(arr)) then + nend_orig = 0 + allocate(arr(nsrc)) + else + if (present(nold)) then + nend_orig = nold + else + nend_orig = size(arr) + end if + call util_resize(arr, nend_orig + nsrc) + end if + nnew = nend_orig + nsrc + + if (present(lsource_mask)) then + arr(nend_orig + 1:nnew) = pack(source(1:nsrc), lsource_mask(1:nsrc)) + else + arr(nend_orig + 1:nnew) = source(1:nsrc) + end if - if (allocated(self%item)) deallocate(self%item) - allocate(self%item, source=source) - return - end subroutine base_util_copy_store + end subroutine base_util_append_arr_char_string + + + subroutine base_util_append_arr_DP(arr, source, nold, lsource_mask) + !! author: David A. Minton + !! + !! Append a single array of double precision type onto another. If the destination array is not allocated, or is not big enough, this will allocate space for it. + implicit none + ! Arguments + real(DP), dimension(:), allocatable, intent(inout) :: arr !! Destination array + real(DP), dimension(:), allocatable, intent(in) :: source !! Array to append + integer(I4B), intent(in), optional :: nold !! Extent of original array. If passed, the source array will begin at arr(nold+1). Otherwise, the size of arr will be used. + logical, dimension(:), intent(in), optional :: lsource_mask !! Logical mask indicating which elements to append to + ! Internals + integer(I4B) :: nnew, nsrc, nend_orig + + if (.not.allocated(source)) return + + if (present(lsource_mask)) then + nsrc = count(lsource_mask(:)) + else + nsrc = size(source) + end if + if (nsrc == 0) return + + if (.not.allocated(arr)) then + nend_orig = 0 + allocate(arr(nsrc)) + else + if (present(nold)) then + nend_orig = nold + else + nend_orig = size(arr) + end if + call util_resize(arr, nend_orig + nsrc) + end if + nnew = nend_orig + nsrc + + if (present(lsource_mask)) then + arr(nend_orig + 1:nnew) = pack(source(1:nsrc), lsource_mask(1:nsrc)) + else + arr(nend_orig + 1:nnew) = source(1:nsrc) + end if + + return + end subroutine base_util_append_arr_DP + + + subroutine base_util_append_arr_DPvec(arr, source, nold, lsource_mask) + !! author: David A. Minton + !! + !! Append a single array of double precision vector type of size (NDIM, n) onto another. If the destination array is not allocated, or is not big enough, this will allocate space for it. + implicit none + ! Arguments + real(DP), dimension(:,:), allocatable, intent(inout) :: arr !! Destination array + real(DP), dimension(:,:), allocatable, intent(in) :: source !! Array to append + integer(I4B), intent(in), optional :: nold !! Extent of original array. If passed, the source array will begin at arr(nold+1). Otherwise, the size of arr will be used. + logical, dimension(:), intent(in), optional :: lsource_mask !! Logical mask indicating which elements to append to + ! Internals + integer(I4B) :: nnew, nsrc, nend_orig + + if (.not.allocated(source)) return + + if (present(lsource_mask)) then + nsrc = count(lsource_mask(:)) + else + nsrc = size(source,dim=2) + end if + if (nsrc == 0) return + + if (.not.allocated(arr)) then + nend_orig = 0 + allocate(arr(NDIM,nsrc)) + else + if (present(nold)) then + nend_orig = nold + else + nend_orig = size(arr,dim=2) + end if + call util_resize(arr, nend_orig + nsrc) + end if + nnew = nend_orig + nsrc + + if (present(lsource_mask)) then + arr(1, nend_orig + 1:nnew) = pack(source(1,1:nsrc), lsource_mask(1:nsrc)) + arr(2, nend_orig + 1:nnew) = pack(source(2,1:nsrc), lsource_mask(1:nsrc)) + arr(3, nend_orig + 1:nnew) = pack(source(3,1:nsrc), lsource_mask(1:nsrc)) + else + arr(:,nend_orig + 1:nnew) = source(:,1:nsrc) + end if + + return + end subroutine base_util_append_arr_DPvec + + + subroutine base_util_append_arr_I4B(arr, source, nold, lsource_mask) + !! author: David A. Minton + !! + !! Append a single array of integer(I4B) onto another. If the destination array is not allocated, or is not big enough, this will allocate space for it. + implicit none + ! Arguments + integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Destination array + integer(I4B), dimension(:), allocatable, intent(in) :: source !! Array to append + integer(I4B), intent(in), optional :: nold !! Extent of original array. If passed, the source array will begin at arr(nold+1). Otherwise, the size of arr will be used. + logical, dimension(:), intent(in), optional :: lsource_mask !! Logical mask indicating which elements to append to + ! Internals + integer(I4B) :: nnew, nsrc, nend_orig + + if (.not.allocated(source)) return + + if (present(lsource_mask)) then + nsrc = count(lsource_mask(:)) + else + nsrc = size(source) + end if + if (nsrc == 0) return + + if (.not.allocated(arr)) then + nend_orig = 0 + allocate(arr(nsrc)) + else + if (present(nold)) then + nend_orig = nold + else + nend_orig = size(arr) + end if + call util_resize(arr, nend_orig + nsrc) + end if + nnew = nend_orig + nsrc + + if (present(lsource_mask)) then + arr(nend_orig + 1:nnew) = pack(source(1:nsrc), lsource_mask(1:nsrc)) + else + arr(nend_orig + 1:nnew) = source(1:nsrc) + end if + + return + end subroutine base_util_append_arr_I4B - subroutine base_util_dealloc_multibody(self) + subroutine base_util_append_arr_logical(arr, source, nold, lsource_mask) !! author: David A. Minton !! - !! Finalize the multibody body object - deallocates all allocatables + !! Append a single array of logical type onto another. If the destination array is not allocated, or is not big enough, this will allocate space for it. implicit none - ! Argument - class(base_multibody), intent(inout) :: self + ! Arguments + logical, dimension(:), allocatable, intent(inout) :: arr !! Destination array + logical, dimension(:), allocatable, intent(in) :: source !! Array to append + integer(I4B), intent(in), optional :: nold !! Extent of original array. If passed, the source array will begin at arr(nold+1). Otherwise, the size of arr will be used. + logical, dimension(:), intent(in), optional :: lsource_mask !! Logical mask indicating which elements to append to + ! Internals + integer(I4B) :: nnew, nsrc, nend_orig + + if (.not.allocated(source)) return + + if (present(lsource_mask)) then + nsrc = count(lsource_mask(:)) + else + nsrc = size(source) + end if + if (nsrc == 0) return - self%nbody = 0 - if (allocated(self%id)) deallocate(self%id) + if (.not.allocated(arr)) then + nend_orig = 0 + allocate(arr(nsrc)) + else + if (present(nold)) then + nend_orig = nold + else + nend_orig = size(arr) + end if + call util_resize(arr, nend_orig + nsrc) + end if + nnew = nend_orig + nsrc + + if (present(lsource_mask)) then + arr(nend_orig + 1:nnew) = pack(source(1:nsrc), lsource_mask(1:nsrc)) + else + arr(nend_orig + 1:nnew) = source(:) + end if + + return + end subroutine base_util_append_arr_logical + + + subroutine base_util_copy_store(self, source) + !! author: David A. Minton + !! + !! Stores a snapshot of the nbody system so that later it can be retrieved for saving to file. + implicit none + class(base_storage_frame), intent(inout) :: self !! Swiftest storage frame object + class(*), intent(in) :: source !! Swiftest n-body system object + if (allocated(self%item)) deallocate(self%item) + allocate(self%item, source=source) + return - end subroutine base_util_dealloc_multibody + end subroutine base_util_copy_store subroutine base_util_dealloc_param(self) @@ -263,9 +538,6 @@ subroutine base_util_dealloc_param(self) ! Arguments class(base_parameters),intent(inout) :: self !! Collection of parameters - if (allocated(self%integrator)) deallocate(self%integrator) - if (allocated(self%param_file_name)) deallocate(self%param_file_name) - if (allocated(self%display_style)) deallocate(self%display_style) if (allocated(self%seed)) deallocate(self%seed) return @@ -324,6 +596,109 @@ subroutine base_util_exit(code) end subroutine base_util_exit + subroutine base_util_fill_arr_char_string(keeps, inserts, lfill_list) + !! author: David A. Minton + !! + !! Performs a fill operation on a single array of type character strings + !! This is the inverse of a spill operation + implicit none + ! Arguments + character(len=STRMAX), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + character(len=STRMAX), dimension(:), allocatable, intent(in) :: inserts !! Array of values to insert into keep + logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps + + if (.not.allocated(keeps) .or. .not.allocated(inserts)) return + + keeps(:) = unpack(keeps(:), .not.lfill_list(:), keeps(:)) + keeps(:) = unpack(inserts(:), lfill_list(:), keeps(:)) + + return + end subroutine base_util_fill_arr_char_string + + + subroutine base_util_fill_arr_DP(keeps, inserts, lfill_list) + !! author: David A. Minton + !! + !! Performs a fill operation on a single array of type DP + !! This is the inverse of a spill operation + implicit none + ! Arguments + real(DP), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + real(DP), dimension(:), allocatable, intent(in) :: inserts !! Array of values to insert into keep + logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps + + if (.not.allocated(keeps) .or. .not.allocated(inserts)) return + + keeps(:) = unpack(keeps(:), .not.lfill_list(:), keeps(:)) + keeps(:) = unpack(inserts(:), lfill_list(:), keeps(:)) + + return + end subroutine base_util_fill_arr_DP + + + subroutine base_util_fill_arr_DPvec(keeps, inserts, lfill_list) + !! author: David A. Minton + !! + !! Performs a fill operation on a single array of DP vectors with shape (NDIM, n) + !! This is the inverse of a spill operation + implicit none + ! Arguments + real(DP), dimension(:,:), allocatable, intent(inout) :: keeps !! Array of values to keep + real(DP), dimension(:,:), allocatable, intent(in) :: inserts !! Array of values to insert into keep + logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps + ! Internals + integer(I4B) :: i + + if (.not.allocated(keeps) .or. .not.allocated(inserts)) return + + do i = 1, NDIM + keeps(i,:) = unpack(keeps(i,:), .not.lfill_list(:), keeps(i,:)) + keeps(i,:) = unpack(inserts(i,:), lfill_list(:), keeps(i,:)) + end do + + return + end subroutine base_util_fill_arr_DPvec + + + subroutine base_util_fill_arr_I4B(keeps, inserts, lfill_list) + !! author: David A. Minton + !! + !! Performs a fill operation on a single array of type I4B + !! This is the inverse of a spill operation + implicit none + ! Arguments + integer(I4B), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + integer(I4B), dimension(:), allocatable, intent(in) :: inserts !! Array of values to insert into keep + logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps + + if (.not.allocated(keeps) .or. .not.allocated(inserts)) return + + keeps(:) = unpack(keeps(:), .not.lfill_list(:), keeps(:)) + keeps(:) = unpack(inserts(:), lfill_list(:), keeps(:)) + + return + end subroutine base_util_fill_arr_I4B + + + subroutine base_util_fill_arr_logical(keeps, inserts, lfill_list) + !! author: David A. Minton + !! + !! Performs a fill operation on a single array of logicals + !! This is the inverse of a spill operation + implicit none + ! Arguments + logical, dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + logical, dimension(:), allocatable, intent(in) :: inserts !! Array of values to insert into keep + logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps + + if (.not.allocated(keeps) .or. .not.allocated(inserts)) return + + keeps(:) = unpack(keeps(:), .not.lfill_list(:), keeps(:)) + keeps(:) = unpack(inserts(:), lfill_list(:), keeps(:)) + + return + end subroutine base_util_fill_arr_logical + subroutine base_util_reset_storage(self) !! author: David A. Minton !! @@ -351,6 +726,237 @@ subroutine base_util_reset_storage(self) return end subroutine base_util_reset_storage + + subroutine base_util_resize_arr_char_string(arr, nnew) + !! author: David A. Minton + !! + !! Resizes an array component of type character string. nnew = 0 will deallocate. + implicit none + ! Arguments + character(len=STRMAX), dimension(:), allocatable, intent(inout) :: arr !! Array to resize + integer(I4B), intent(in) :: nnew !! New size + ! Internals + character(len=STRMAX), dimension(:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated + integer(I4B) :: nold !! Old size + + if (nnew < 0) return + + if (nnew == 0) then + if (allocated(arr)) deallocate(arr) + return + end if + + if (allocated(arr)) then + nold = size(arr) + else + nold = 0 + end if + + if (nnew == nold) return + + allocate(tmp(nnew)) + if (nold > 0) then + if (nnew > nold) then + tmp(1:nold) = arr(1:nold) + tmp(nold+1:nnew) = "" + else + tmp(1:nnew) = arr(1:nnew) + end if + else + tmp(1:nnew) = "" + end if + call move_alloc(tmp, arr) + + return + end subroutine base_util_resize_arr_char_string + + + subroutine base_util_resize_arr_DP(arr, nnew) + !! author: David A. Minton + !! + !! Resizes an array component of double precision type. Passing nnew = 0 will deallocate. + implicit none + ! Arguments + real(DP), dimension(:), allocatable, intent(inout) :: arr !! Array to resize + integer(I4B), intent(in) :: nnew !! New size + ! Internals + real(DP), dimension(:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated + integer(I4B) :: nold !! Old size + real(DP), parameter :: init_val = 0.0_DP + + if (nnew < 0) return + + if (nnew == 0) then + if (allocated(arr)) deallocate(arr) + return + end if + + if (allocated(arr)) then + nold = size(arr) + else + nold = 0 + end if + + if (nnew == nold) return + + allocate(tmp(nnew)) + if (nold > 0) then + if (nnew > nold) then + tmp(1:nold) = arr(1:nold) + tmp(nold+1:nnew) = init_val + else + tmp(1:nnew) = arr(1:nnew) + end if + else + tmp(1:nnew) = init_val + end if + call move_alloc(tmp, arr) + + return + end subroutine base_util_resize_arr_DP + + + subroutine base_util_resize_arr_DPvec(arr, nnew) + !! author: David A. Minton + !! + !! Resizes an array component of double precision vectors of size (NDIM, n). Passing nnew = 0 will deallocate. + implicit none + ! Arguments + real(DP), dimension(:,:), allocatable, intent(inout) :: arr !! Array to resize + integer(I4B), intent(in) :: nnew !! New size + ! Internals + real(DP), dimension(:,:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated + integer(I4B) :: nold !! Old size + real(DP), dimension(NDIM), parameter :: init_val = 0.0_DP + integer(I4B) :: i + + if (nnew < 0) return + + if (nnew == 0) then + if (allocated(arr)) deallocate(arr) + return + end if + + if (allocated(arr)) then + nold = size(arr, dim=2) + else + nold = 0 + end if + + if (nnew == nold) return + + allocate(tmp(NDIM, nnew)) + if (nold > 0) then + if (nnew > nold) then + tmp(:,1:nold) = arr(:,1:nold) + do i = nold+1, nnew + tmp(:,i) = init_val(:) + end do + else + tmp(:,1:nnew) = arr(:,1:nnew) + end if + else + do i = 1, nnew + tmp(:, i) = init_val(:) + end do + end if + call move_alloc(tmp, arr) + + return + + return + end subroutine base_util_resize_arr_DPvec + + + subroutine base_util_resize_arr_I4B(arr, nnew) + !! author: David A. Minton + !! + !! Resizes an array component of integer type. Passing nnew = 0 will deallocate. + implicit none + ! Arguments + integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Array to resize + integer(I4B), intent(in) :: nnew !! New size + ! Internals + integer(I4B), dimension(:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated + integer(I4B) :: nold !! Old size + integer(I4B), parameter :: init_val = -1 + + if (nnew < 0) return + + if (nnew == 0) then + if (allocated(arr)) deallocate(arr) + return + end if + + if (allocated(arr)) then + nold = size(arr) + else + nold = 0 + end if + + if (nnew == nold) return + + allocate(tmp(nnew)) + if (nold > 0) then + if (nnew > nold) then + tmp(1:nold) = arr(1:nold) + tmp(nold+1:nnew) = init_val + else + tmp(1:nnew) = arr(1:nnew) + end if + else + tmp(1:nnew) = init_val + end if + call move_alloc(tmp, arr) + + return + end subroutine base_util_resize_arr_I4B + + + subroutine base_util_resize_arr_logical(arr, nnew) + !! author: David A. Minton + !! + !! Resizes an array component of logical type. Passing nnew = 0 will deallocate. + implicit none + ! Arguments + logical, dimension(:), allocatable, intent(inout) :: arr !! Array to resize + integer(I4B), intent(in) :: nnew !! New size + ! Internals + logical, dimension(:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated + integer(I4B) :: nold !! Old size + logical, parameter :: init_val = .false. + + if (nnew < 0) return + + if (nnew == 0) then + if (allocated(arr)) deallocate(arr) + return + end if + + if (allocated(arr)) then + nold = size(arr) + else + nold = 0 + end if + + if (nnew == nold) return + + allocate(tmp(nnew)) + if (nold > 0) then + if (nnew > nold) then + tmp(1:nold) = arr(1:nold) + tmp(nold+1:nnew) = init_val + else + tmp(1:nnew) = arr(1:nnew) + end if + else + tmp = init_val + end if + call move_alloc(tmp, arr) + + return + end subroutine base_util_resize_arr_logical + subroutine base_util_resize_storage(self, nnew) !! author: David A. Minton @@ -408,7 +1014,7 @@ subroutine base_util_snapshot_save(self, snapshot) !! Memory usage grows by a factor of 2 each time it fills up, but no more. implicit none ! Arguments - class(base_storage), intent(inout) :: self !! Storage ncounter storage object + class(base_storage), intent(inout) :: self !! Storage encounter storage object class(*), intent(in) :: snapshot !! Object to snapshot ! Internals integer(I4B) :: nnew, nold @@ -426,19 +1032,1104 @@ subroutine base_util_snapshot_save(self, snapshot) return end subroutine base_util_snapshot_save - - subroutine base_final_storage(self) + + subroutine base_util_spill_arr_char_string(keeps, discards, lspill_list, ldestructive) !! author: David A. Minton !! - !! Finalizer for the storage object + !! Performs a spill operation on a single array of type character strings + !! This is the inverse of a spill operation implicit none ! Arguments - class(base_storage), intent(inout) :: self + character(len=STRMAX), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + character(len=STRMAX), dimension(:), allocatable, intent(inout) :: discards !! Array of discards + logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards + logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not + ! Internals + integer(I4B) :: nspill, nkeep, nlist + character(len=STRMAX), dimension(:), allocatable :: tmp !! Array of values to keep - call self%dealloc() - return - end subroutine base_final_storage + nkeep = count(.not.lspill_list(:)) + nspill = count(lspill_list(:)) + nlist = size(lspill_list(:)) + + if (.not.allocated(keeps) .or. nspill == 0) return + if (size(keeps) < nkeep) return + if (.not.allocated(discards)) then + allocate(discards(nspill)) + else if (size(discards) /= nspill) then + deallocate(discards) + allocate(discards(nspill)) + end if + + discards(:) = pack(keeps(1:nlist), lspill_list(1:nlist)) + if (ldestructive) then + if (nkeep > 0) then + allocate(tmp(nkeep)) + tmp(:) = pack(keeps(1:nlist), .not. lspill_list(1:nlist)) + call move_alloc(tmp, keeps) + else + deallocate(keeps) + end if + end if + + return + end subroutine base_util_spill_arr_char_string + + + subroutine base_util_spill_arr_DP(keeps, discards, lspill_list, ldestructive) + !! author: David A. Minton + !! + !! Performs a spill operation on a single array of type DP + !! This is the inverse of a spill operation + implicit none + ! Arguments + real(DP), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + real(DP), dimension(:), allocatable, intent(inout) :: discards !! Array of discards + logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discardss + logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not + ! Internals + integer(I4B) :: nspill, nkeep, nlist + real(DP), dimension(:), allocatable :: tmp !! Array of values to keep + + nkeep = count(.not.lspill_list(:)) + nspill = count(lspill_list(:)) + nlist = size(lspill_list(:)) + + if (.not.allocated(keeps) .or. nspill == 0) return + if (size(keeps) < nkeep) return + if (.not.allocated(discards)) then + allocate(discards(nspill)) + else if (size(discards) /= nspill) then + deallocate(discards) + allocate(discards(nspill)) + end if + + discards(:) = pack(keeps(1:nlist), lspill_list(1:nlist)) + if (ldestructive) then + if (nkeep > 0) then + allocate(tmp(nkeep)) + tmp(:) = pack(keeps(1:nlist), .not. lspill_list(1:nlist)) + call move_alloc(tmp, keeps) + else + deallocate(keeps) + end if + end if + + return + end subroutine base_util_spill_arr_DP + + + subroutine base_util_spill_arr_DPvec(keeps, discards, lspill_list, ldestructive) + !! author: David A. Minton + !! + !! Performs a spill operation on a single array of DP vectors with shape (NDIM, n) + !! This is the inverse of a spill operation + implicit none + ! Arguments + real(DP), dimension(:,:), allocatable, intent(inout) :: keeps !! Array of values to keep + real(DP), dimension(:,:), allocatable, intent(inout) :: discards !! Array discards + logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards + logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not + ! Internals + integer(I4B) :: i, nspill, nkeep, nlist + real(DP), dimension(:,:), allocatable :: tmp !! Array of values to keep + + nkeep = count(.not.lspill_list(:)) + nspill = count(lspill_list(:)) + nlist = size(lspill_list(:)) + + if (.not.allocated(keeps) .or. nspill == 0) return + if (size(keeps) < nkeep) return + if (.not.allocated(discards)) then + allocate(discards(NDIM, nspill)) + else if (size(discards, dim=2) /= nspill) then + deallocate(discards) + allocate(discards(NDIM, nspill)) + end if + + do i = 1, NDIM + discards(i,:) = pack(keeps(i,1:nlist), lspill_list(1:nlist)) + end do + if (ldestructive) then + if (nkeep > 0) then + allocate(tmp(NDIM, nkeep)) + do i = 1, NDIM + tmp(i, :) = pack(keeps(i, 1:nlist), .not. lspill_list(1:nlist)) + end do + call move_alloc(tmp, keeps) + else + deallocate(keeps) + end if + end if + + return + end subroutine base_util_spill_arr_DPvec + + + subroutine base_util_spill_arr_I4B(keeps, discards, lspill_list, ldestructive) + !! author: David A. Minton + !! + !! Performs a spill operation on a single array of type I4B + !! This is the inverse of a spill operation + implicit none + ! Arguments + integer(I4B), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + integer(I4B), dimension(:), allocatable, intent(inout) :: discards !! Array of discards + logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards + logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not + ! Internals + integer(I4B) :: nspill, nkeep, nlist + integer(I4B), dimension(:), allocatable :: tmp !! Array of values to keep + + nkeep = count(.not.lspill_list(:)) + nspill = count(lspill_list(:)) + nlist = size(lspill_list(:)) + + if (.not.allocated(keeps) .or. nspill == 0) return + if (size(keeps) < nkeep) return + if (.not.allocated(discards)) then + allocate(discards(nspill)) + else if (size(discards) /= nspill) then + deallocate(discards) + allocate(discards(nspill)) + end if + + discards(:) = pack(keeps(1:nlist), lspill_list(1:nlist)) + if (ldestructive) then + if (nkeep > 0) then + allocate(tmp(nkeep)) + tmp(:) = pack(keeps(1:nlist), .not. lspill_list(1:nlist)) + call move_alloc(tmp, keeps) + else + deallocate(keeps) + end if + end if + + return + end subroutine base_util_spill_arr_I4B + + + subroutine base_util_spill_arr_I8B(keeps, discards, lspill_list, ldestructive) + !! author: David A. Minton + !! + !! Performs a spill operation on a single array of type I4B + !! This is the inverse of a spill operation + implicit none + ! Arguments + integer(I8B), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + integer(I8B), dimension(:), allocatable, intent(inout) :: discards !! Array of discards + logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards + logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not + ! Internals + integer(I4B) :: nspill, nkeep, nlist + integer(I8B), dimension(:), allocatable :: tmp !! Array of values to keep + + nkeep = count(.not.lspill_list(:)) + nspill = count(lspill_list(:)) + nlist = size(lspill_list(:)) + + if (.not.allocated(keeps) .or. nspill == 0) return + if (size(keeps) < nkeep) return + if (.not.allocated(discards)) then + allocate(discards(nspill)) + else if (size(discards) /= nspill) then + deallocate(discards) + allocate(discards(nspill)) + end if + + discards(:) = pack(keeps(1:nlist), lspill_list(1:nlist)) + if (ldestructive) then + if (nkeep > 0) then + allocate(tmp(nkeep)) + tmp(:) = pack(keeps(1:nlist), .not. lspill_list(1:nlist)) + call move_alloc(tmp, keeps) + else + deallocate(keeps) + end if + end if + + return + end subroutine base_util_spill_arr_I8B + + + subroutine base_util_spill_arr_logical(keeps, discards, lspill_list, ldestructive) + !! author: David A. Minton + !! + !! Performs a spill operation on a single array of logicals + !! This is the inverse of a spill operation + implicit none + ! Arguments + logical, dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + logical, dimension(:), allocatable, intent(inout) :: discards !! Array of discards + logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards + logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or no + ! Internals + integer(I4B) :: nspill, nkeep, nlist + logical, dimension(:), allocatable :: tmp !! Array of values to keep + + nkeep = count(.not.lspill_list(:)) + nspill = count(lspill_list(:)) + nlist = size(lspill_list(:)) + + if (.not.allocated(keeps) .or. nspill == 0) return + if (size(keeps) < nkeep) return + if (.not.allocated(discards)) then + allocate(discards(nspill)) + else if (size(discards) /= nspill) then + deallocate(discards) + allocate(discards(nspill)) + end if + + discards(:) = pack(keeps(1:nlist), lspill_list(1:nlist)) + if (ldestructive) then + if (nkeep > 0) then + allocate(tmp(nkeep)) + tmp(:) = pack(keeps(1:nlist), .not. lspill_list(1:nlist)) + call move_alloc(tmp, keeps) + else + deallocate(keeps) + end if + end if + + return + end subroutine base_util_spill_arr_logical + + + pure subroutine base_util_sort_dp(arr) + !! author: David A. Minton + !! + !! Sort input DP precision array in place into ascending numerical order using quicksort. + !! + implicit none + ! Arguments + real(DP), dimension(:), intent(inout) :: arr + + call base_util_sort_qsort_DP(arr) + + return + end subroutine base_util_sort_dp + + + pure subroutine base_util_sort_index_dp(arr, ind) + !! author: David A. Minton + !! + !! Sort input DP precision array by index in ascending numerical order using quick sort. + !! This algorithm works well for partially sorted arrays (which is usually the case here). + !! If ind is supplied already allocated, we assume it is an existing index array (e.g. a previously + !! sorted array). If it is not allocated, this subroutine swiftest_allocates it. + !! + implicit none + ! Arguments + real(DP), dimension(:), intent(in) :: arr + integer(I4B), dimension(:), allocatable, intent(inout) :: ind + ! Internals + integer(I4B) :: n, i + real(DP), dimension(:), allocatable :: tmparr + + n = size(arr) + if (.not.allocated(ind)) then + allocate(ind(n)) + ind = [(i, i=1, n)] + end if + allocate(tmparr, mold=arr) + tmparr(:) = arr(ind(:)) + call base_util_sort_qsort_DP(tmparr, ind) + + return + end subroutine base_util_sort_index_dp + + + recursive pure subroutine base_util_sort_qsort_DP(arr, ind) + !! author: David A. Minton + !! + !! Sort input DP precision array by index in ascending numerical order using quicksort sort. + !! + implicit none + ! Arguments + real(DP), dimension(:), intent(inout) :: arr + integer(I4B),dimension(:),intent(out), optional :: ind + !! Internals + integer :: iq + + if (size(arr) > 1) then + if (present(ind)) then + call base_util_sort_partition_DP(arr, iq, ind) + call base_util_sort_qsort_DP(arr(:iq-1),ind(:iq-1)) + call base_util_sort_qsort_DP(arr(iq:), ind(iq:)) + else + call base_util_sort_partition_DP(arr, iq) + call base_util_sort_qsort_DP(arr(:iq-1)) + call base_util_sort_qsort_DP(arr(iq:)) + end if + end if + + return + end subroutine base_util_sort_qsort_DP + + + pure subroutine base_util_sort_partition_DP(arr, marker, ind) + !! author: David A. Minton + !! + !! Partition function for quicksort on DP type + !! + implicit none + ! Arguments + real(DP), intent(inout), dimension(:) :: arr + integer(I4B), intent(inout), dimension(:), optional :: ind + integer(I4B), intent(out) :: marker + ! Internals + integer(I4B) :: i, j, itmp, narr, ipiv + real(DP) :: temp + real(DP) :: x ! pivot point + + narr = size(arr) + + ! Get center as pivot, as this is likely partially sorted + ipiv = narr / 2 + x = arr(ipiv) + i = 0 + j = narr + 1 + + do + j = j - 1 + do + if (arr(j) <= x) exit + j = j - 1 + end do + i = i + 1 + do + if (arr(i) >= x) exit + i = i + 1 + end do + if (i < j) then + ! exchange A(i) and A(j) + temp = arr(i) + arr(i) = arr(j) + arr(j) = temp + if (present(ind)) then + itmp = ind(i) + ind(i) = ind(j) + ind(j) = itmp + end if + else if (i == j) then + marker = i + 1 + return + else + marker = i + return + endif + end do + + return + end subroutine base_util_sort_partition_DP + + + pure subroutine base_util_sort_i4b(arr) + !! author: David A. Minton + !! + !! Sort input integer array in place into ascending numerical order using quick sort. + !! This algorithm works well for partially sorted arrays (which is usually the case here) + !! + implicit none + ! Arguments + integer(I4B), dimension(:), intent(inout) :: arr + + call base_util_sort_qsort_I4B(arr) + + return + end subroutine base_util_sort_i4b + + + pure subroutine base_util_sort_index_I4B(arr, ind) + !! author: David A. Minton + !! + !! Sort input integer array by index in ascending numerical order using quicksort. + !! If ind is supplied already allocated, we assume it is an existing index array (e.g. a previously + !! sorted array). If it is not allocated, this subroutine swiftest_allocates it. + !! + implicit none + ! Arguments + integer(I4B), dimension(:), intent(in) :: arr + integer(I4B), dimension(:), allocatable, intent(inout) :: ind + ! Internals + integer(I4B) :: n, i + integer(I4B), dimension(:), allocatable :: tmparr + + n = size(arr) + if (.not.allocated(ind)) then + allocate(ind(n)) + ind = [(i, i=1, n)] + end if + allocate(tmparr, mold=arr) + tmparr(:) = arr(ind(:)) + call base_util_sort_qsort_I4B(tmparr, ind) + + return + end subroutine base_util_sort_index_I4B + + + pure subroutine base_util_sort_index_I4B_I8Bind(arr, ind) + !! author: David A. Minton + !! + !! Sort input integer array by index in ascending numerical order using quicksort. + !! If ind is supplied already allocated, we assume it is an existing index array (e.g. a previously + !! sorted array). If it is not allocated, this subroutine swiftest_allocates it. + !! + implicit none + ! Arguments + integer(I4B), dimension(:), intent(in) :: arr + integer(I8B), dimension(:), allocatable, intent(inout) :: ind + ! Internals + integer(I8B) :: n, i + integer(I4B), dimension(:), allocatable :: tmparr + + n = size(arr) + if (.not.allocated(ind)) then + allocate(ind(n)) + ind = [(i, i=1_I8B, n)] + end if + allocate(tmparr, mold=arr) + tmparr(:) = arr(ind(:)) + call base_util_sort_qsort_I4B_I8Bind(tmparr, ind) + + return + end subroutine base_util_sort_index_I4B_I8Bind + + + pure subroutine base_util_sort_index_I8B_I8Bind(arr, ind) + !! author: David A. Minton + !! + !! Sort input integer array by index in ascending numerical order using quicksort. + !! If ind is supplied already allocated, we assume it is an existing index array (e.g. a previously + !! sorted array). If it is not allocated, this subroutine swiftest_allocates it. + !! + implicit none + ! Arguments + integer(I8B), dimension(:), intent(in) :: arr + integer(I8B), dimension(:), allocatable, intent(inout) :: ind + ! Internals + integer(I8B) :: n, i + integer(I8B), dimension(:), allocatable :: tmparr + + n = size(arr) + if (.not.allocated(ind)) then + allocate(ind(n)) + ind = [(i, i=1_I8B, n)] + end if + allocate(tmparr, mold=arr) + tmparr(:) = arr(ind(:)) + call base_util_sort_qsort_I8B_I8Bind(tmparr, ind) + + return + end subroutine base_util_sort_index_I8B_I8Bind + + + recursive pure subroutine base_util_sort_qsort_I4B(arr, ind) + !! author: David A. Minton + !! + !! Sort input I4B array by index in ascending numerical order using quicksort. + !! + implicit none + ! Arguments + integer(I4B), dimension(:), intent(inout) :: arr + integer(I4B), dimension(:), intent(out), optional :: ind + ! Internals + integer(I4B) :: iq + + if (size(arr) > 1) then + if (present(ind)) then + call base_util_sort_partition_I4B(arr, iq, ind) + call base_util_sort_qsort_I4B(arr(:iq-1),ind(:iq-1)) + call base_util_sort_qsort_I4B(arr(iq:), ind(iq:)) + else + call base_util_sort_partition_I4B(arr, iq) + call base_util_sort_qsort_I4B(arr(:iq-1)) + call base_util_sort_qsort_I4B(arr(iq:)) + end if + end if + + return + end subroutine base_util_sort_qsort_I4B + + + recursive pure subroutine base_util_sort_qsort_I4B_I8Bind(arr, ind) + !! author: David A. Minton + !! + !! Sort input I4B array by index in ascending numerical order using quicksort. + !! + implicit none + ! Arguments + integer(I4B), dimension(:), intent(inout) :: arr + integer(I8B), dimension(:), intent(out), optional :: ind + ! Internals + integer(I8B) :: iq + + if (size(arr) > 1_I8B) then + if (present(ind)) then + call base_util_sort_partition_I4B_I8Bind(arr, iq, ind) + call base_util_sort_qsort_I4B_I8Bind(arr(:iq-1_I8B),ind(:iq-1_I8B)) + call base_util_sort_qsort_I4B_I8Bind(arr(iq:), ind(iq:)) + else + call base_util_sort_partition_I4B_I8Bind(arr, iq) + call base_util_sort_qsort_I4B_I8Bind(arr(:iq-1_I8B)) + call base_util_sort_qsort_I4B_I8Bind(arr(iq:)) + end if + end if + + return + end subroutine base_util_sort_qsort_I4B_I8Bind + + + recursive pure subroutine base_util_sort_qsort_I8B_I8Bind(arr, ind) + !! author: David A. Minton + !! + !! Sort input I8B array by index in ascending numerical order using quicksort. + !! + implicit none + ! Arguments + integer(I8B), dimension(:), intent(inout) :: arr + integer(I8B), dimension(:), intent(out), optional :: ind + ! Internals + integer(I8B) :: iq + + if (size(arr) > 1_I8B) then + if (present(ind)) then + call base_util_sort_partition_I8B_I8Bind(arr, iq, ind) + call base_util_sort_qsort_I8B_I8Bind(arr(:iq-1_I8B),ind(:iq-1_I8B)) + call base_util_sort_qsort_I8B_I8Bind(arr(iq:), ind(iq:)) + else + call base_util_sort_partition_I8B_I8Bind(arr, iq) + call base_util_sort_qsort_I8B_I8Bind(arr(:iq-1_I8B)) + call base_util_sort_qsort_I8B_I8Bind(arr(iq:)) + end if + end if + + return + end subroutine base_util_sort_qsort_I8B_I8Bind + + + pure subroutine base_util_sort_partition_I4B(arr, marker, ind) + !! author: David A. Minton + !! + !! Partition function for quicksort on I4B type + !! + implicit none + ! Arguments + integer(I4B), intent(inout), dimension(:) :: arr + integer(I4B), intent(inout), dimension(:), optional :: ind + integer(I4B), intent(out) :: marker + ! Internals + integer(I4B) :: i, j, itmp, narr, ipiv + integer(I4B) :: temp + integer(I4B) :: x ! pivot point + + narr = size(arr) + + ! Get center as pivot, as this is likely partially sorted + ipiv = narr / 2 + x = arr(ipiv) + i = 0 + j = narr + 1 + + do + j = j - 1 + do + if (arr(j) <= x) exit + j = j - 1 + end do + i = i + 1 + do + if (arr(i) >= x) exit + i = i + 1 + end do + if (i < j) then + ! exchange A(i) and A(j) + temp = arr(i) + arr(i) = arr(j) + arr(j) = temp + if (present(ind)) then + itmp = ind(i) + ind(i) = ind(j) + ind(j) = itmp + end if + else if (i == j) then + marker = i + 1 + return + else + marker = i + return + endif + end do + + return + end subroutine base_util_sort_partition_I4B + + + pure subroutine base_util_sort_partition_I4B_I8Bind(arr, marker, ind) + !! author: David A. Minton + !! + !! Partition function for quicksort on I4B type + !! + implicit none + ! Arguments + integer(I4B), intent(inout), dimension(:) :: arr + integer(I8B), intent(inout), dimension(:), optional :: ind + integer(I8B), intent(out) :: marker + ! Internals + integer(I8B) :: i, j, itmp, narr, ipiv + integer(I4B) :: temp + integer(I8B) :: x ! pivot point + + narr = size(arr) + + ! Get center as pivot, as this is likely partially sorted + ipiv = narr / 2_I8B + x = arr(ipiv) + i = 0_I8B + j = narr + 1_I8B + + do + j = j - 1_I8B + do + if (arr(j) <= x) exit + j = j - 1_I8B + end do + i = i + 1_I8B + do + if (arr(i) >= x) exit + i = i + 1_I8B + end do + if (i < j) then + ! exchange A(i) and A(j) + temp = arr(i) + arr(i) = arr(j) + arr(j) = temp + if (present(ind)) then + itmp = ind(i) + ind(i) = ind(j) + ind(j) = itmp + end if + else if (i == j) then + marker = i + 1_I8B + return + else + marker = i + return + endif + end do + + return + end subroutine base_util_sort_partition_I4B_I8Bind + + + pure subroutine base_util_sort_partition_I8B_I8Bind(arr, marker, ind) + !! author: David A. Minton + !! + !! Partition function for quicksort on I8B type with I8B index + !! + implicit none + ! Arguments + integer(I8B), intent(inout), dimension(:) :: arr + integer(I8B), intent(inout), dimension(:), optional :: ind + integer(I8B), intent(out) :: marker + ! Internals + integer(I8B) :: i, j, itmp, narr, ipiv + integer(I8B) :: temp + integer(I8B) :: x ! pivot point + + narr = size(arr) + + ! Get center as pivot, as this is likely partially sorted + ipiv = narr / 2_I8B + x = arr(ipiv) + i = 0_I8B + j = narr + 1_I8B + + do + j = j - 1_I8B + do + if (arr(j) <= x) exit + j = j - 1_I8B + end do + i = i + 1_I8B + do + if (arr(i) >= x) exit + i = i + 1_I8B + end do + if (i < j) then + ! exchange A(i) and A(j) + temp = arr(i) + arr(i) = arr(j) + arr(j) = temp + if (present(ind)) then + itmp = ind(i) + ind(i) = ind(j) + ind(j) = itmp + end if + else if (i == j) then + marker = i + 1_I8B + return + else + marker = i + return + endif + end do + + return + end subroutine base_util_sort_partition_I8B_I8Bind + + + pure subroutine base_util_sort_sp(arr) + !! author: David A. Minton + !! + !! Sort input DP precision array in place into ascending numerical order using quicksort. + !! + implicit none + ! Arguments + real(SP), dimension(:), intent(inout) :: arr + + call base_util_sort_qsort_SP(arr) + + return + end subroutine base_util_sort_sp + + + pure subroutine base_util_sort_index_sp(arr, ind) + !! author: David A. Minton + !! + !! Sort input DP precision array by index in ascending numerical order using quicksort. + !! If ind is supplied already allocated, we assume it is an existing index array (e.g. a previously + !! sorted array). If it is not allocated, this subroutine swiftest_allocates it. + !! + implicit none + ! Arguments + real(SP), dimension(:), intent(in) :: arr + integer(I4B), dimension(:), allocatable, intent(inout) :: ind + ! Internals + integer(I4B) :: n, i + real(SP), dimension(:), allocatable :: tmparr + + n = size(arr) + if (.not.allocated(ind)) then + allocate(ind(n)) + ind = [(i, i=1, n)] + end if + allocate(tmparr, mold=arr) + tmparr(:) = arr(ind(:)) + call base_util_sort_qsort_SP(tmparr, ind) + + return + end subroutine base_util_sort_index_sp + + + recursive pure subroutine base_util_sort_qsort_SP(arr, ind) + !! author: David A. Minton + !! + !! Sort input DP precision array by index in ascending numerical order using quicksort. + !! + implicit none + ! Arguments + real(SP), dimension(:), intent(inout) :: arr + integer(I4B),dimension(:),intent(out), optional :: ind + !! Internals + integer :: iq + + if (size(arr) > 1) then + if (present(ind)) then + call base_util_sort_partition_SP(arr, iq, ind) + call base_util_sort_qsort_SP(arr(:iq-1),ind(:iq-1)) + call base_util_sort_qsort_SP(arr(iq:), ind(iq:)) + else + call base_util_sort_partition_SP(arr, iq) + call base_util_sort_qsort_SP(arr(:iq-1)) + call base_util_sort_qsort_SP(arr(iq:)) + end if + end if + + return + end subroutine base_util_sort_qsort_SP + + + pure subroutine base_util_sort_partition_SP(arr, marker, ind) + !! author: David A. Minton + !! + !! Partition function for quicksort on SP type + !! + implicit none + ! Arguments + real(SP), intent(inout), dimension(:) :: arr + integer(I4B), intent(inout), dimension(:), optional :: ind + integer(I4B), intent(out) :: marker + ! Internals + integer(I4B) :: i, j, itmp, narr, ipiv + real(SP) :: temp + real(SP) :: x ! pivot point + + narr = size(arr) + + ! Get center as pivot, as this is likely partially sorted + ipiv = narr / 2 + x = arr(ipiv) + i = 0 + j = narr + 1 + + do + j = j - 1 + do + if (arr(j) <= x) exit + j = j - 1 + end do + i = i + 1 + do + if (arr(i) >= x) exit + i = i + 1 + end do + if (i < j) then + ! exchange A(i) and A(j) + temp = arr(i) + arr(i) = arr(j) + arr(j) = temp + if (present(ind)) then + itmp = ind(i) + ind(i) = ind(j) + ind(j) = itmp + end if + else if (i == j) then + marker = i + 1 + return + else + marker = i + return + endif + end do + + return + end subroutine base_util_sort_partition_SP + + + pure subroutine base_util_sort_rearrange_arr_char_string(arr, ind, n) + !! author: David A. Minton + !! + !! Rearrange a single array of character string in-place from an index list. + implicit none + ! Arguments + character(len=STRMAX), dimension(:), allocatable, intent(inout) :: arr !! Destination array + integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against + integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange + ! Internals + character(len=STRMAX), dimension(:), allocatable :: tmp !! Temporary copy of arry used during rearrange operation + + if (.not. allocated(arr) .or. n <= 0) return + allocate(tmp, mold=arr) + tmp(1:n) = arr(ind) + call move_alloc(tmp, arr) + + return + end subroutine base_util_sort_rearrange_arr_char_string + + + pure subroutine base_util_sort_rearrange_arr_DP(arr, ind, n) + !! author: David A. Minton + !! + !! Rearrange a single array of DP type in-place from an index list. + implicit none + ! Arguments + real(DP), dimension(:), allocatable, intent(inout) :: arr !! Destination array + integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against + integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange + ! Internals + real(DP), dimension(:), allocatable :: tmp !! Temporary copy of array used during rearrange operation + + if (.not. allocated(arr) .or. n <= 0) return + allocate(tmp, mold=arr) + tmp(1:n) = arr(ind) + call move_alloc(tmp, arr) + + return + end subroutine base_util_sort_rearrange_arr_DP + + + pure subroutine base_util_sort_rearrange_arr_DPvec(arr, ind, n) + !! author: David A. Minton + !! + !! Rearrange a single array of (NDIM,n) DP-type vectors in-place from an index list. + implicit none + ! Arguments + real(DP), dimension(:,:), allocatable, intent(inout) :: arr !! Destination array + integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against + integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange + ! Internals + real(DP), dimension(:,:), allocatable :: tmp !! Temporary copy of array used during rearrange operation + + if (.not. allocated(arr) .or. n <= 0) return + allocate(tmp, mold=arr) + tmp(:,1:n) = arr(:, ind) + call move_alloc(tmp, arr) + + return + end subroutine base_util_sort_rearrange_arr_DPvec + + + pure subroutine base_util_sort_rearrange_arr_I4B(arr, ind, n) + !! author: David A. Minton + !! + !! Rearrange a single array of integers in-place from an index list. + implicit none + ! Arguments + integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Destination array + integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against + integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange + ! Internals + integer(I4B), dimension(:), allocatable :: tmp !! Temporary copy of array used during rearrange operation + + if (.not. allocated(arr) .or. n <= 0) return + allocate(tmp, mold=arr) + tmp(1:n) = arr(ind) + call move_alloc(tmp, arr) + + return + end subroutine base_util_sort_rearrange_arr_I4B + + pure subroutine base_util_sort_rearrange_arr_I4B_I8Bind(arr, ind, n) + !! author: David A. Minton + !! + !! Rearrange a single array of integers in-place from an index list. + implicit none + ! Arguments + integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Destination array + integer(I8B), dimension(:), intent(in) :: ind !! Index to rearrange against + integer(I8B), intent(in) :: n !! Number of elements in arr and ind to rearrange + ! Internals + integer(I4B), dimension(:), allocatable :: tmp !! Temporary copy of array used during rearrange operation + + if (.not. allocated(arr) .or. n <= 0_I8B) return + allocate(tmp, mold=arr) + tmp(1:n) = arr(ind) + call move_alloc(tmp, arr) + + return + end subroutine base_util_sort_rearrange_arr_I4B_I8Bind + + + pure subroutine base_util_sort_rearrange_arr_logical_I8Bind(arr, ind, n) + !! author: David A. Minton + !! + !! Rearrange a single array of logicals in-place from an index list. + implicit none + ! Arguments + logical, dimension(:), allocatable, intent(inout) :: arr !! Destination array + integer(I8B), dimension(:), intent(in) :: ind !! Index to rearrange against + integer(I8B), intent(in) :: n !! Number of elements in arr and ind to rearrange + ! Internals + logical, dimension(:), allocatable :: tmp !! Temporary copy of array used during rearrange operation + + if (.not. allocated(arr) .or. n <= 0) return + allocate(tmp, mold=arr) + tmp(1:n) = arr(ind) + call move_alloc(tmp, arr) + + return + end subroutine base_util_sort_rearrange_arr_logical_I8Bind + + + pure subroutine base_util_sort_rearrange_arr_logical(arr, ind, n) + !! author: David A. Minton + !! + !! Rearrange a single array of logicals in-place from an index list. + implicit none + ! Arguments + logical, dimension(:), allocatable, intent(inout) :: arr !! Destination array + integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against + integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange + ! Internals + logical, dimension(:), allocatable :: tmp !! Temporary copy of array used during rearrange operation + + if (.not. allocated(arr) .or. n <= 0) return + allocate(tmp, mold=arr) + tmp(1:n) = arr(ind) + call move_alloc(tmp, arr) + + return + end subroutine base_util_sort_rearrange_arr_logical + + + subroutine base_util_unique_DP(input_array, output_array, index_map) + !! author: David A. Minton + !! + !! Takes an input unsorted integer array and returns a new array of sorted, unique values (DP version) + implicit none + ! Arguments + real(DP), dimension(:), intent(in) :: input_array !! Unsorted input array + real(DP), dimension(:), allocatable, intent(out) :: output_array !! Sorted array of unique values + integer(I4B), dimension(:), allocatable, intent(out) :: index_map !! An array of the same size as input_array that such that any for any index i, output_array(index_map(i)) = input_array(i) + ! Internals + real(DP), dimension(:), allocatable :: unique_array + integer(I4B) :: n + real(DP) :: lo, hi + + allocate(unique_array, mold=input_array) + allocate(index_map(size(input_array))) + lo = minval(input_array) - 1 + hi = maxval(input_array) + + n = 0 + do + n = n + 1 + lo = minval(input_array(:), mask=input_array(:) > lo) + unique_array(n) = lo + where(input_array(:) == lo) index_map(:) = n + if (lo >= hi) exit + enddo + allocate(output_array(n), source=unique_array(1:n)) + + return + end subroutine base_util_unique_DP + + + subroutine base_util_unique_I4B(input_array, output_array, index_map) + !! author: David A. Minton + !! + !! Takes an input unsorted integer array and returns a new array of sorted, unique values (I4B version) + implicit none + ! Arguments + integer(I4B), dimension(:), intent(in) :: input_array !! Unsorted input array + integer(I4B), dimension(:), allocatable, intent(out) :: output_array !! Sorted array of unique values + integer(I4B), dimension(:), allocatable, intent(out) :: index_map !! An array of the same size as input_array that such that any for any index i, output_array(index_map(i)) = input_array(i) + ! Internals + integer(I4B), dimension(:), allocatable :: unique_array + integer(I4B) :: n, lo, hi + + allocate(unique_array, mold=input_array) + allocate(index_map, mold=input_array) + lo = minval(input_array) - 1 + hi = maxval(input_array) + + n = 0 + do + n = n + 1 + lo = minval(input_array(:), mask=input_array(:) > lo) + unique_array(n) = lo + where(input_array(:) == lo) index_map(:) = n + if (lo >= hi) exit + enddo + allocate(output_array(n), source=unique_array(1:n)) + + return + end subroutine base_util_unique_I4B + + + subroutine base_final_storage(self) + !! author: David A. Minton + !! + !! Finalizer for the storage object + implicit none + ! Arguments + class(base_storage), intent(inout) :: self + + call self%dealloc() + return + end subroutine base_final_storage subroutine base_final_storage_frame(self) @@ -453,5 +2144,97 @@ subroutine base_final_storage_frame(self) return end subroutine base_final_storage_frame +#ifdef COARRAY + subroutine base_coclone_param(self) + !! author: David A. Minton + !! + !! Broadcasts the image 1 parameter to all other images in a parameter coarray + implicit none + ! Arguments + class(base_parameters),intent(inout),codimension[*] :: self !! Collection of parameters + ! Internals + + call coclone(self%integrator) + call coclone(self%param_file_name) + call coclone(self%t0) + call coclone(self%tstart) + call coclone(self%tstop) + call coclone(self%dt) + call coclone(self%iloop) + call coclone(self%nloops) + call coclone(self%incbfile) + call coclone(self%inplfile) + call coclone(self%intpfile) + call coclone(self%nc_in) + call coclone(self%in_type) + call coclone(self%in_form) + call coclone(self%istep_out) + call coclone(self%nstep_out) + call coclone(self%fstep_out) + call coclone(self%ltstretch) + call coclone(self%outfile) + call coclone(self%out_type) + call coclone(self%out_form) + call coclone(self%out_stat) + call coclone(self%dump_cadence) + call coclone(self%rmin) + call coclone(self%rmax) + call coclone(self%rmaxu) + call coclone(self%qmin) + call coclone(self%qmin_coord) + call coclone(self%qmin_alo) + call coclone(self%qmin_ahi) + call coclone(self%MU2KG) + call coclone(self%TU2S) + call coclone(self%DU2M) + call coclone(self%GU) + call coclone(self%inv_c2) + call coclone(self%GMTINY) + call coclone(self%min_GMfrag) + call coclone(self%nfrag_reduction) + call coclone(self%lmtiny_pl) + call coclone(self%collision_model) + call coclone(self%encounter_save) + call coclone(self%lenc_save_trajectory) + call coclone(self%lenc_save_closest ) + call coclone(self%interaction_loops ) + call coclone(self%encounter_check_plpl) + call coclone(self%encounter_check_pltp) + call coclone(self%lflatten_interactions) + call coclone(self%lencounter_sas_plpl) + call coclone(self%lencounter_sas_pltp ) + call coclone(self%lrhill_present) + call coclone(self%lextra_force ) + call coclone(self%lbig_discard ) + call coclone(self%lclose ) + call coclone(self%lenergy ) + call coclone(self%loblatecb ) + call coclone(self%lrotation ) + call coclone(self%ltides ) + call coclone(self%E_orbit_orig ) + call coclone(self%GMtot_orig ) + call coclonevec(self%L_total_orig) + call coclonevec(self%L_orbit_orig) + call coclonevec(self%L_spin_orig) + call coclonevec(self%L_escape) + call coclone(self%GMescape ) + call coclone(self%E_collisions ) + call coclone(self%E_untracked ) + call coclone(self%lfirstenergy) + call coclone(self%lfirstkick ) + call coclone(self%lrestart ) + call coclone(self%display_style) + call coclone(self%display_unit ) + call coclone(self%log_output ) + call coclone(self%lgr ) + call coclone(self%lyarkovsky) + call coclone(self%lyorp ) + call coclone(self%seed) + call coclone(self%lcoarray) + + return + end subroutine base_coclone_param +#endif + end module base diff --git a/src/coarray/coarray_clone.f90 b/src/coarray/coarray_clone.f90 new file mode 100644 index 000000000..9f7e1ea1a --- /dev/null +++ b/src/coarray/coarray_clone.f90 @@ -0,0 +1,507 @@ +!! Copyright 2023 - David Minton +!! This file is part of Swiftest. +!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License +!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. +!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty +!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. +!! You should have received a copy of the GNU General Public License along with Swiftest. +!! If not, see: https://www.gnu.org/licenses. + +submodule (coarray) s_coarray_clone + use swiftest +contains + + module subroutine coarray_component_clone_char(var,src_img) + !! author: David A. Minton + !! + !! Copies a component of a coarray derived type from the specified source image to the current local one. The default source image is 1 + !! character scalar version + implicit none + ! Arguments + character(len=*), intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + ! Internals + character(len=STRMAX),allocatable :: tmp[:] + integer(I4B) :: img, si + + allocate(tmp[*]) + if (present(src_img)) then + si = src_img + else + si = 1 + end if + + sync all + if (this_image() == si) then + do img = 1, num_images() + tmp[img] = var + end do + sync images(*) + else + sync images(si) + var = tmp[si] + end if + deallocate(tmp) + + return + end subroutine coarray_component_clone_char + + + module subroutine coarray_component_clone_DP(var,src_img) + !! author: David A. Minton + !! + !! Copies a component of a coarray derived type from the specified source image to the current local one. The default source image is 1 + !! real(DP) scalar version + implicit none + ! Arguments + real(DP), intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + ! Internals + real(DP),allocatable :: tmp[:] + integer(I4B) :: img, si + + allocate(tmp[*]) + + if (present(src_img)) then + si = src_img + else + si = 1 + end if + + sync all + if (this_image() == si) then + do img = 1, num_images() + tmp[img] = var + end do + sync images(*) + else + sync images(si) + var = tmp[si] + end if + + deallocate(tmp) + + return + end subroutine coarray_component_clone_DP + + + module subroutine coarray_component_clone_DP_arr1D(var,src_img) + !! author: David A. Minton + !! + !! Copies a component of a coarray derived type from the specified source image to the current local one. The default source image is 1 + !! real(DP) 1D allocatable array version + implicit none + ! Arguments + real(DP), dimension(:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + ! Internals + real(DP), dimension(:), codimension[:], allocatable :: tmp + integer(I4B) :: img, si + integer(I4B), allocatable :: n[:] + logical, allocatable :: isalloc[:] + + allocate(isalloc[*]) + allocate(n[*]) + + if (present(src_img)) then + si = src_img + else + si = 1 + end if + + isalloc = allocated(var) + if (isalloc) n = size(var) + sync all + if (.not. isalloc[si]) return + + allocate(tmp(n[si])[*]) + if (this_image() == si) then + do img = 1, num_images() + tmp(:)[img] = var + end do + sync images(*) + else + sync images(si) + if (allocated(var)) deallocate(var) + allocate(var, source=tmp) + end if + deallocate(isalloc,n,tmp) + + return + end subroutine coarray_component_clone_DP_arr1D + + + module subroutine coarray_component_clone_DP_arr2D(var,src_img) + !! author: David A. Minton + !! + !! Copies a component of a coarray derived type from the specified source image to the current local one. The default source image is 1 + !! real(DP) 2D allocatable array version + implicit none + ! Arguments + real(DP), dimension(:,:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + ! Internals + real(DP), dimension(:,:), codimension[:], allocatable :: tmp + integer(I4B) :: img, si + integer(I4B), allocatable :: n1[:], n2[:] + logical, allocatable :: isalloc[:] + + allocate(n1[*]) + allocate(n2[*]) + allocate(isalloc[*]) + + if (present(src_img)) then + si = src_img + else + si = 1 + end if + + isalloc = allocated(var) + if (isalloc) then + n1 = size(var,dim=1) + n2 = size(var,dim=2) + end if + sync all + if (.not. isalloc[si]) return + + allocate(tmp(n1[si],n2[si])[*]) + if (this_image() == si) then + do img = 1, num_images() + tmp(:,:)[img] = var(:,:) + end do + sync images(*) + else + sync images(si) + if (allocated(var)) deallocate(var) + allocate(var, source=tmp) + end if + + deallocate(isalloc,n1,n2,tmp) + + return + end subroutine coarray_component_clone_DP_arr2D + + + module subroutine coarray_component_clone_DP_vec1D(var,src_img) + !! author: David A. Minton + !! + !! Copies a component of a coarray derived type from the specified source image to the current local one. The default source image is 1 + !! real(DP) 1D (NDIM) array version + implicit none + ! Arguments + real(DP), dimension(:), intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + ! Internals + real(DP), dimension(:), codimension[:], allocatable :: tmp + integer(I4B) :: img, si + integer(I4B), allocatable :: n[:] + + allocate(n[*]) + if (present(src_img)) then + si = src_img + else + si = 1 + end if + + allocate(tmp(NDIM)[*]) + if (this_image() == si) then + do img = 1, num_images() + tmp(:)[img] = var(:) + end do + sync images(*) + else + sync images(si) + var(:) = tmp(:)[si] + end if + + deallocate(tmp) + + return + end subroutine coarray_component_clone_DP_vec1D + + + module subroutine coarray_component_clone_DP_vec2D(var,src_img) + !! author: David A. Minton + !! + !! Copies a component of a coarray derived type from the specified source image to the current local one. The default source image is 1 + !! real(DP) 1D allocatable array version + implicit none + ! Arguments + real(DP), dimension(:,:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + ! Internals + real(DP), dimension(:,:), codimension[:], allocatable :: tmp + integer(I4B) :: img, si + integer(I4B), allocatable :: n[:] + logical, allocatable :: isalloc[:] + + allocate(isalloc[*]) + allocate(n[*]) + + if (present(src_img)) then + si = src_img + else + si = 1 + end if + + isalloc = allocated(var) + if (isalloc) n = size(var,dim=2) + sync all + if (.not. isalloc[si]) return + + allocate(tmp(NDIM,n[si])[*]) + if (this_image() == si) then + do img = 1, num_images() + tmp(:,:)[img] = var(:,:) + end do + sync images(*) + else + sync images(si) + if (allocated(var)) deallocate(var) + allocate(var, source=tmp) + end if + + deallocate(isalloc,n,tmp) + + return + end subroutine coarray_component_clone_DP_vec2D + + + module subroutine coarray_component_clone_I4B(var,src_img) + !! author: David A. Minton + !! + !! Copies a component of a coarray derived type from the specified source image to the current local one. The default source image is 1 + !! integer(I4B) scalar version + implicit none + ! Arguments + integer(I4B), intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + ! Internals + integer(I4B),allocatable :: tmp[:] + integer(I4B) :: img, si + + allocate(tmp[*]) + + if (present(src_img)) then + si = src_img + else + si = 1 + end if + + if (this_image() == si) then + do img = 1, num_images() + tmp[img] = var + end do + sync images(*) + else + sync images(si) + var = tmp[si] + end if + + deallocate(tmp) + + return + end subroutine coarray_component_clone_I4B + + + module subroutine coarray_component_clone_I4B_arr1D(var,src_img) + !! author: David A. Minton + !! + !! Copies a component of a coarray derived type from the specified source image to the current local one. The default source image is 1 + !! integer(I4B) 1D allocatable array version + implicit none + ! Arguments + integer(I4B), dimension(:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + ! Internals + integer(I4B), dimension(:), codimension[:], allocatable :: tmp + integer(I4B) :: img, si + integer(I4B), allocatable :: n[:] + logical, allocatable :: isalloc[:] + + allocate(isalloc[*]) + allocate(n[*]) + if (present(src_img)) then + si = src_img + else + si = 1 + end if + + isalloc = allocated(var) + if (isalloc) n = size(var) + sync all + if (.not. isalloc[si]) return + + allocate(tmp(n[si])[*]) + if (this_image() == si) then + do img = 1, num_images() + tmp(:)[img] = var + end do + sync images(*) + else + sync images(si) + if (allocated(var)) deallocate(var) + allocate(var, source=tmp) + end if + + deallocate(isalloc,n,tmp) + + return + end subroutine coarray_component_clone_I4B_arr1D + + + module subroutine coarray_component_clone_I8B(var,src_img) + !! author: David A. Minton + !! + !! Copies a component of a coarray derived type from the specified source image to the current local one. The default source image is 1 + !! integer(I4B) scalar version + implicit none + ! Arguments + integer(I8B), intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + ! Internals + integer(I8B),allocatable :: tmp[:] + integer(I4B) :: img, si + + allocate(tmp[*]) + if (present(src_img)) then + si = src_img + else + si = 1 + end if + + if (this_image() == si) then + do img = 1, num_images() + tmp[img] = var + end do + sync images(*) + else + sync images(si) + var = tmp[si] + end if + + deallocate(tmp) + + return + end subroutine coarray_component_clone_I8B + + + module subroutine coarray_component_clone_lgt(var,src_img) + !! author: David A. Minton + !! + !! Copies a component of a coarray derived type from the specified source image to the current local one. The default source image is 1 + !! logical scalar version + implicit none + ! Arguments + logical, intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + ! Internals + logical,allocatable :: tmp[:] + integer(I4B) :: img, si + + allocate(tmp[*]) + + if (present(src_img)) then + si = src_img + else + si = 1 + end if + + if (this_image() == si) then + do img = 1, num_images() + tmp[img] = var + end do + sync images(*) + else + sync images(si) + var = tmp[si] + end if + + deallocate(tmp) + + return + end subroutine coarray_component_clone_lgt + + + module subroutine coarray_component_clone_lgt_arr1D(var,src_img) + !! author: David A. Minton + !! + !! Copies a component of a coarray derived type from the specified source image to the current local one. The default source image is 1 + !! logical 1D allocatable array version + implicit none + ! Arguments + logical, dimension(:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + ! Internals + logical, dimension(:), codimension[:], allocatable :: tmp + integer(I4B) :: img, si + integer(I4B), allocatable :: n[:] + logical, allocatable :: isalloc[:] + + allocate(isalloc[*]) + allocate(n[*]) + if (present(src_img)) then + si = src_img + else + si = 1 + end if + + isalloc = allocated(var) + if (isalloc) n = size(var) + sync all + if (.not. isalloc[si]) return + + allocate(tmp(n[si])[*]) + if (this_image() == si) then + do img = 1, num_images() + tmp(:)[img] = var + end do + sync images(*) + else + sync images(si) + if (allocated(var)) deallocate(var) + allocate(var, source=tmp) + end if + + deallocate(isalloc,n,tmp) + + return + end subroutine coarray_component_clone_lgt_arr1D + + + module subroutine coarray_component_clone_QP(var,src_img) + !! author: David A. Minton + !! + !! Copies a component of a coarray derived type from the specified source image to the current local one. The default source image is 1 + !! real(DP) scalar version + implicit none + ! Arguments + real(QP), intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + ! Internals + real(QP),allocatable :: tmp[:] + integer(I4B) :: img, si + + allocate(tmp[*]) + if (present(src_img)) then + si = src_img + else + si = 1 + end if + + if (this_image() == si) then + do img = 1, num_images() + tmp[img] = var + end do + sync images(*) + else + sync images(si) + var = tmp[si] + end if + + deallocate(tmp) + + return + end subroutine coarray_component_clone_QP + +end submodule s_coarray_clone \ No newline at end of file diff --git a/src/coarray/coarray_collect.f90 b/src/coarray/coarray_collect.f90 new file mode 100644 index 000000000..566113a07 --- /dev/null +++ b/src/coarray/coarray_collect.f90 @@ -0,0 +1,325 @@ +!! Copyright 2023 - David Minton +!! This file is part of Swiftest. +!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License +!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. +!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty +!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. +!! You should have received a copy of the GNU General Public License along with Swiftest. +!! If not, see: https://www.gnu.org/licenses. + +submodule (coarray) s_coarray_collect + use swiftest +contains + + module subroutine coarray_component_collect_DP_arr1D(var,dest_img) + !! author: David A. Minton + !! + !! Collects components of a coarray derived type from all images and combines them into destination image component. The default destination image is 1 + !! real(DP) 1D allocatable array version + implicit none + ! Arguments + real(DP), dimension(:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: dest_img + ! Internals + real(DP), dimension(:), codimension[:], allocatable :: tmp + integer(I4B) :: i,img, ti, di, istart, iend, nmax + integer(I4B), allocatable :: n[:] + logical, allocatable :: isalloc[:] + + allocate(isalloc[*]) + allocate(n[*]) + + if (present(dest_img)) then + di = dest_img + else + di = 1 + end if + + isalloc = allocated(var) + if (isalloc) then + n = size(var) + else + n = 0 + end if + + sync all + + nmax = 0 + do img = 1, num_images() + if (n[img] > nmax) nmax = n[img] + end do + + allocate(tmp(nmax)[*]) + if (isalloc) tmp(1:n) = var(1:n) + + if (this_image() == di) then + do img = 1, num_images() + if (img /= di) then + call util_append(var, tmp(1:n[img])[img]) + n = n + n[img] + end if + end do + sync images(*) + else + sync images(di) + if (allocated(var)) deallocate(var) + end if + + deallocate(isalloc,n,tmp) + + return + end subroutine coarray_component_collect_DP_arr1D + + + module subroutine coarray_component_collect_DP_arr2D(var,dest_img) + !! author: David A. Minton + !! + !! Collects components of a coarray derived type from all images and combines them into destination image component . The default destination image is 1 + !! real(DP) 2D allocatable array version + implicit none + ! Arguments + real(DP), dimension(:,:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: dest_img + ! Internals + real(DP), dimension(:,:), codimension[:], allocatable :: tmp + integer(I4B) :: i, img, ti, di, ntot, istart, iend, nmax + integer(I4B), allocatable :: n1[:], n2[:] + logical, allocatable :: isalloc[:] + + allocate(n1[*]) + allocate(n2[*]) + allocate(isalloc[*]) + + if (present(dest_img)) then + di = dest_img + else + di = 1 + end if + + isalloc = allocated(var) + if (isalloc) then + n1 = size(var,dim=1) + n2 = size(var,dim=2) + else + n1 = 0 + n2 = 0 + end if + sync all + + nmax = 0 + do img = 1, num_images() + if (n2[img] > nmax) nmax = n2[img] + end do + + allocate(tmp(NDIM,nmax)[*]) + if (isalloc) tmp(:,1:n2) = var(:,1:n2) + + if (this_image() == di) then + do img = 1, num_images() + if (img /= di) then + call util_append(var, tmp(:,:)[img]) + n2 = n2 + n2[img] + end if + end do + sync images(*) + else + sync images(di) + if (allocated(var)) deallocate(var) + end if + + deallocate(isalloc,n1,n2,tmp) + + return + end subroutine coarray_component_collect_DP_arr2D + + + module subroutine coarray_component_collect_I4B(var,dest_img) + !! author: David A. Minton + !! + !! Sums this component of a coarray derived type from all images and places the value in the destination image component. The default destination image is 1 + !! integer(I4B) version + implicit none + ! Arguments + integer(I4B), intent(inout) :: var + integer(I4B), intent(in),optional :: dest_img + ! Internals + integer(I4B), allocatable :: tmp[:] + integer(I4B) :: img, di + + if (present(dest_img)) then + di = dest_img + else + di = 1 + end if + + allocate(tmp[*], source=var) + + if (this_image() == di) then + var = 0 + do img = 1, num_images() + var = var + tmp[img] + end do + else + var = 0 + end if + + deallocate(tmp) + + return + end subroutine coarray_component_collect_I4B + + + module subroutine coarray_component_collect_I8B(var,dest_img) + !! author: David A. Minton + !! + !! Sums this component of a coarray derived type from all images and places the value in the destination image component. The default destination image is 1 + !! integer(I8B) version + implicit none + ! Arguments + integer(I8B), intent(inout) :: var + integer(I4B), intent(in),optional :: dest_img + ! Internals + integer(I8B), allocatable :: tmp[:] + integer(I4B) :: img, di + + if (present(dest_img)) then + di = dest_img + else + di = 1 + end if + + allocate(tmp[*], source=var) + + if (this_image() == di) then + var = 0 + do img = 1, num_images() + var = var + tmp[img] + end do + else + var = 0 + end if + + deallocate(tmp) + + return + end subroutine coarray_component_collect_I8B + + + module subroutine coarray_component_collect_I4B_arr1D(var,dest_img) + !! author: David A. Minton + !! + !! Collects components of a coarray derived type from all images and combines them into destination image component . The default destination image is 1 + !! integer(I4B) 1D allocatable array version + implicit none + ! Arguments + integer(I4B), dimension(:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: dest_img + ! Internals + integer(I4B), dimension(:), codimension[:], allocatable :: tmp + integer(I4B) :: i,img, ti, di, istart, iend, nmax + integer(I4B), allocatable :: n[:] + logical, allocatable :: isalloc[:] + + allocate(isalloc[*]) + allocate(n[*]) + + if (present(dest_img)) then + di = dest_img + else + di = 1 + end if + + isalloc = allocated(var) + if (isalloc) then + n = size(var) + else + n = 0 + end if + sync all + nmax = 0 + do img = 1, num_images() + if (n[img] > nmax) nmax = n[img] + end do + + allocate(tmp(nmax)[*]) + if (isalloc) tmp(1:n) = var(1:n) + + if (this_image() == di) then + do img = 1, num_images() + if (img /= di) then + call util_append(var, tmp(1:n[img])[img]) + n = n + n[img] + end if + end do + sync images(*) + else + sync images(di) + if (allocated(var)) deallocate(var) + end if + + deallocate(isalloc,n,tmp) + + return + end subroutine coarray_component_collect_I4B_arr1D + + + module subroutine coarray_component_collect_lgt_arr1D(var,dest_img) + !! author: David A. Minton + !! + !! Collects components of a coarray derived type from all images and combines them into destination image component . The default destination image is 1 + !! logical 1D allocatable array version + implicit none + ! Arguments + logical, dimension(:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: dest_img + ! Internals + logical, dimension(:), codimension[:], allocatable :: tmp + integer(I4B) :: i,img, ti, di, ntot, istart, iend, nmax + integer(I4B), allocatable :: n[:] + logical, allocatable :: isalloc[:] + + allocate(isalloc[*]) + allocate(n[*]) + + if (present(dest_img)) then + di = dest_img + else + di = 1 + end if + + isalloc = allocated(var) + if (isalloc) then + n = size(var) + else + n = 0 + end if + sync all + nmax = 0 + do img = 1, num_images() + if (n[img] > nmax) nmax = n[img] + end do + + allocate(tmp(nmax)[*]) + if (isalloc) tmp(1:n) = var(1:n) + + if (this_image() == di) then + do img = 1, num_images() + if (img /= di) then + call util_append(var, tmp(1:n[img])[img]) + n = n + n[img] + end if + end do + sync images(*) + else + sync images(di) + if (allocated(var)) deallocate(var) + end if + + deallocate(isalloc,n,tmp) + + return + end subroutine coarray_component_collect_lgt_arr1D + + + +end submodule s_coarray_collect \ No newline at end of file diff --git a/src/coarray/coarray_module.f90 b/src/coarray/coarray_module.f90 new file mode 100644 index 000000000..b034f8786 --- /dev/null +++ b/src/coarray/coarray_module.f90 @@ -0,0 +1,142 @@ +!! Copyright 2023 - David Minton +!! This file is part of Swiftest. +!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License +!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. +!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty +!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. +!! You should have received a copy of the GNU General Public License along with Swiftest. +!! If not, see: https://www.gnu.org/licenses. + +module coarray + !! author: David A. Minton + !! + !! Utilities that are used for coarray test particles + !! + use globals + implicit none + public + + interface coclone + module subroutine coarray_component_clone_char(var,src_img) + implicit none + character(len=*), intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + end subroutine coarray_component_clone_char + + module subroutine coarray_component_clone_DP(var,src_img) + implicit none + real(DP), intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + end subroutine coarray_component_clone_DP + + module subroutine coarray_component_clone_DP_arr1D(var,src_img) + implicit none + real(DP), dimension(:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + end subroutine coarray_component_clone_DP_arr1D + + module subroutine coarray_component_clone_DP_arr2D(var,src_img) + implicit none + real(DP), dimension(:,:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + end subroutine coarray_component_clone_DP_arr2D + + module subroutine coarray_component_clone_I4B(var,src_img) + implicit none + integer(I4B), intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + end subroutine coarray_component_clone_I4B + + module subroutine coarray_component_clone_I4B_arr1D(var,src_img) + implicit none + integer(I4B), dimension(:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + end subroutine coarray_component_clone_I4B_arr1D + + module subroutine coarray_component_clone_I8B(var,src_img) + implicit none + integer(I8B), intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + end subroutine coarray_component_clone_I8B + + module subroutine coarray_component_clone_lgt(var,src_img) + implicit none + logical, intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + end subroutine coarray_component_clone_lgt + + module subroutine coarray_component_clone_lgt_arr1D(var,src_img) + implicit none + logical, dimension(:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + end subroutine coarray_component_clone_lgt_arr1D + + module subroutine coarray_component_clone_QP(var,src_img) + implicit none + real(QP), intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + end subroutine coarray_component_clone_QP + end interface + + + interface coclonevec + module subroutine coarray_component_clone_DP_vec1D(var,src_img) + implicit none + real(DP), dimension(:), intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + end subroutine coarray_component_clone_DP_vec1D + + module subroutine coarray_component_clone_DP_vec2D(var,src_img) + implicit none + real(DP), dimension(:,:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + end subroutine coarray_component_clone_DP_vec2D + end interface coclonevec + + + interface cocollect + module subroutine coarray_component_collect_DP_arr1D(var,dest_img) + implicit none + real(DP), dimension(:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: dest_img + end subroutine coarray_component_collect_DP_arr1D + + + module subroutine coarray_component_collect_DP_arr2D(var,dest_img) + implicit none + real(DP), dimension(:,:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: dest_img + end subroutine coarray_component_collect_DP_arr2D + + + module subroutine coarray_component_collect_I4B(var,dest_img) + implicit none + integer(I4B), intent(inout) :: var + integer(I4B), intent(in),optional :: dest_img + end subroutine coarray_component_collect_I4B + + + module subroutine coarray_component_collect_I8B(var,dest_img) + implicit none + integer(I8B), intent(inout) :: var + integer(I4B), intent(in),optional :: dest_img + end subroutine coarray_component_collect_I8B + + + module subroutine coarray_component_collect_I4B_arr1D(var,dest_img) + implicit none + integer(I4B), dimension(:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: dest_img + end subroutine coarray_component_collect_I4B_arr1D + + + module subroutine coarray_component_collect_lgt_arr1D(var,dest_img) + implicit none + logical, dimension(:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: dest_img + end subroutine coarray_component_collect_lgt_arr1D + end interface + + + +end module coarray \ No newline at end of file diff --git a/src/collision/collision_module.f90 b/src/collision/collision_module.f90 index 042c67af7..82bec250b 100644 --- a/src/collision/collision_module.f90 +++ b/src/collision/collision_module.f90 @@ -19,7 +19,11 @@ module collision public character(len=*), parameter :: COLLISION_OUTFILE = 'collisions.nc' !! Name of NetCDF output file for collision information +#ifdef COARRAY + character(len=STRMAX) :: COLLISION_LOG_OUT !! Name of log file for collision diagnostic information (each co-image gets its own) +#else character(len=*), parameter :: COLLISION_LOG_OUT = "collisions.log" !! Name of log file for collision diagnostic information +#endif !>Symbolic names for collisional outcomes from collresolve_resolve: integer(I4B), parameter :: COLLRESOLVE_REGIME_MERGE = 1 @@ -97,8 +101,10 @@ module collision !> Class definition for the variables that describe a collection of fragments in barycentric coordinates - type, extends(base_multibody) :: collision_fragments + type, extends(base_object) :: collision_fragments + integer(I4B) :: nbody = 0 !! Number of bodies real(DP) :: mtot !! Total mass of fragments + integer(I4B), dimension(:), allocatable :: id !! Identifier class(base_particle_info), dimension(:), allocatable :: info !! Particle metadata information integer(I4B), dimension(:), allocatable :: status !! An integrator-specific status indicator real(DP), dimension(:,:), allocatable :: rh !! Heliocentric position diff --git a/src/collision/collision_regime.f90 b/src/collision/collision_regime.f90 index be9ec288f..a612eb37a 100644 --- a/src/collision/collision_regime.f90 +++ b/src/collision/collision_regime.f90 @@ -281,19 +281,12 @@ subroutine collision_regime_LS12_SI(Mcb, m1, m2, rad1, rad2, rh1, rh2, vb1, vb2, Mlr = max((1.0_DP - Qr / Qrd_pstar / 2.0_DP) * Mtot, min_mfrag) ! [kg] # LS12 eq (5) end if Mbig = max(m1,Mlr) - Msmall = Mtot - Mbig - if (Msmall < min_mfrag) then - regime = COLLRESOLVE_REGIME_MERGE - Mbig = Mtot - Mslr = 0.0_DP - Mslr_hitandrun = 0.0_DP + Msmall = mtot - Mbig + Mslr_hitandrun = max(calc_Qrd_rev(Msmall, Mbig, Mint, den1, den2, Vimp, c_star), min_mfrag) + if (regime == COLLRESOLVE_REGIME_HIT_AND_RUN ) then + Mslr = Mslr_hitandrun else - Mslr_hitandrun = max(calc_Qrd_rev(Msmall, Mbig, Mint, den1, den2, Vimp, c_star), min_mfrag) - if (regime == COLLRESOLVE_REGIME_HIT_AND_RUN ) then - Mslr = Mslr_hitandrun - else - Mslr = max(Mtot * (3.0_DP - BETA) * (1.0_DP - N1 * Mlr / Mtot) / (N2 * BETA), min_mfrag) !LS12 eq (37) - end if + Mslr = max(Mtot * (3.0_DP - BETA) * (1.0_DP - N1 * Mlr / Mtot) / (N2 * BETA), min_mfrag) !LS12 eq (37) end if Mresidual = Mtot - Mlr - Mslr diff --git a/src/collision/collision_util.f90 b/src/collision/collision_util.f90 index 19a688c8a..95152c0aa 100644 --- a/src/collision/collision_util.f90 +++ b/src/collision/collision_util.f90 @@ -227,7 +227,7 @@ module subroutine collision_util_index_map(self) call self%get_index_values(idvals, tvals) ! Consolidate ids to only unique values - call swiftest_util_unique(idvals,self%idvals,self%idmap) + call util_unique(idvals,self%idvals,self%idmap) self%nid = size(self%idvals) ! Don't consolidate time values (multiple collisions can happen in a single time step) @@ -299,6 +299,8 @@ module subroutine collision_util_dealloc_fragments(self) ! Arguments class(collision_fragments), intent(inout) :: self + self%nbody = 0 + if (allocated(self%id)) deallocate(self%id) if (allocated(self%info)) deallocate(self%info) if (allocated(self%status)) deallocate(self%status) if (allocated(self%rh)) deallocate(self%rh) diff --git a/src/encounter/encounter_check.f90 b/src/encounter/encounter_check.f90 index c2013ce6b..06d0a76d4 100644 --- a/src/encounter/encounter_check.f90 +++ b/src/encounter/encounter_check.f90 @@ -103,10 +103,10 @@ module subroutine encounter_check_all_plplm(param, nplm, nplt, rplm, vplm, rplt, call move_alloc(ltmp, lvdotr) nenc = nenc + plmplt_nenc - call swiftest_util_sort(index1, ind) - call swiftest_util_sort_rearrange(index1, ind, nenc) - call swiftest_util_sort_rearrange(index2, ind, nenc) - call swiftest_util_sort_rearrange(lvdotr, ind, nenc) + call util_sort(index1, ind) + call util_sort_rearrange(index1, ind, nenc) + call util_sort_rearrange(index2, ind, nenc) + call util_sort_rearrange(lvdotr, ind, nenc) end if @@ -677,10 +677,10 @@ subroutine encounter_check_remove_duplicates(n, nenc, index1, index2, lvdotr) return end if - call swiftest_util_sort(index1, ind) - call swiftest_util_sort_rearrange(index1, ind, nenc) - call swiftest_util_sort_rearrange(index2, ind, nenc) - call swiftest_util_sort_rearrange(lvdotr, ind, nenc) + call util_sort(index1, ind) + call util_sort_rearrange(index1, ind, nenc) + call util_sort_rearrange(index2, ind, nenc) + call util_sort_rearrange(lvdotr, ind, nenc) ! Get the bounds on the bodies in the first index ibeg(:) = n @@ -706,7 +706,7 @@ subroutine encounter_check_remove_duplicates(n, nenc, index1, index2, lvdotr) khi = iend(i) nenci = khi - klo + 1_I8B if (allocated(ind)) deallocate(ind) - call swiftest_util_sort(index2(klo:khi), ind) + call util_sort(index2(klo:khi), ind) index2(klo:khi) = itmp(klo - 1_I8B + ind(:)) do j = klo + 1_I8B, khi if (index2(j) == index2(j - 1_I8B)) lencounter(j) = .false. @@ -746,7 +746,7 @@ pure module subroutine encounter_check_sort_aabb_1D(self, n, extent_arr) ! Internals integer(I8B) :: i, k - call swiftest_util_sort(extent_arr, self%ind) + call util_sort(extent_arr, self%ind) do concurrent(k = 1_I8B:2_I8B * n) i = self%ind(k) diff --git a/src/encounter/encounter_module.f90 b/src/encounter/encounter_module.f90 index f3c24c763..bcae2bd15 100644 --- a/src/encounter/encounter_module.f90 +++ b/src/encounter/encounter_module.f90 @@ -259,9 +259,9 @@ end subroutine encounter_util_setup_list module subroutine encounter_util_append_list(self, source, lsource_mask) implicit none - class(encounter_list), intent(inout) :: self !! Swiftest encounter list object - class(encounter_list), intent(in) :: source !! Source object to append - logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + class(encounter_list), intent(inout) :: self !! Swiftest encounter list object + class(encounter_list), intent(in) :: source !! Source object to append + logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to end subroutine encounter_util_append_list module subroutine encounter_util_copy_list(self, source) diff --git a/src/encounter/encounter_util.f90 b/src/encounter/encounter_util.f90 index 01848d571..f935afe5a 100644 --- a/src/encounter/encounter_util.f90 +++ b/src/encounter/encounter_util.f90 @@ -18,28 +18,27 @@ module subroutine encounter_util_append_list(self, source, lsource_mask) !! This method will automatically resize the destination body if it is too small implicit none ! Arguments - class(encounter_list), intent(inout) :: self !! Swiftest encounter list object - class(encounter_list), intent(in) :: source !! Source object to append - logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + class(encounter_list), intent(inout) :: self !! Swiftest encounter list object + class(encounter_list), intent(in) :: source !! Source object to append + logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to ! Internals integer(I4B) :: nold, nsrc nold = int(self%nenc, kind=I4B) - nsrc = int(source%nenc, kind=I4B) - call swiftest_util_append(self%tcollision, source%tcollision, nold, nsrc, lsource_mask) - call swiftest_util_append(self%lclosest, source%lclosest, nold, nsrc, lsource_mask) - call swiftest_util_append(self%lvdotr, source%lvdotr, nold, nsrc, lsource_mask) - call swiftest_util_append(self%status, source%status, nold, nsrc, lsource_mask) - call swiftest_util_append(self%index1, source%index1, nold, nsrc, lsource_mask) - call swiftest_util_append(self%index2, source%index2, nold, nsrc, lsource_mask) - call swiftest_util_append(self%id1, source%id1, nold, nsrc, lsource_mask) - call swiftest_util_append(self%id2, source%id2, nold, nsrc, lsource_mask) - call swiftest_util_append(self%r1, source%r1, nold, nsrc, lsource_mask) - call swiftest_util_append(self%r2, source%r2, nold, nsrc, lsource_mask) - call swiftest_util_append(self%v1, source%v1, nold, nsrc, lsource_mask) - call swiftest_util_append(self%v2, source%v2, nold, nsrc, lsource_mask) - call swiftest_util_append(self%level, source%level, nold, nsrc, lsource_mask) - self%nenc = nold + count(lsource_mask(1:nsrc)) + call util_append(self%tcollision, source%tcollision, nold, lsource_mask) + call util_append(self%lclosest, source%lclosest, nold, lsource_mask) + call util_append(self%lvdotr, source%lvdotr, nold, lsource_mask) + call util_append(self%status, source%status, nold, lsource_mask) + call util_append(self%index1, source%index1, nold, lsource_mask) + call util_append(self%index2, source%index2, nold, lsource_mask) + call util_append(self%id1, source%id1, nold, lsource_mask) + call util_append(self%id2, source%id2, nold, lsource_mask) + call util_append(self%r1, source%r1, nold, lsource_mask) + call util_append(self%r2, source%r2, nold, lsource_mask) + call util_append(self%v1, source%v1, nold, lsource_mask) + call util_append(self%v2, source%v2, nold, lsource_mask) + call util_append(self%level, source%level, nold, lsource_mask) + self%nenc = nold + count(lsource_mask(:)) return end subroutine encounter_util_append_list @@ -283,11 +282,11 @@ module subroutine encounter_util_index_map(self) call encounter_util_get_vals_storage(self, idvals, tvals) ! Consolidate ids to only unique values - call swiftest_util_unique(idvals,self%idvals,self%idmap) + call util_unique(idvals,self%idvals,self%idmap) self%nid = size(self%idvals) ! Consolidate time values to only unique values - call swiftest_util_unique(tvals,self%tvals,self%tmap) + call util_unique(tvals,self%tvals,self%tmap) self%nt = size(self%tvals) return @@ -431,19 +430,19 @@ module subroutine encounter_util_spill_list(self, discards, lspill_list, ldestru integer(I8B) :: nenc_old associate(keeps => self) - call swiftest_util_spill(keeps%tcollision, discards%tcollision, lspill_list, ldestructive) - call swiftest_util_spill(keeps%lvdotr, discards%lvdotr, lspill_list, ldestructive) - call swiftest_util_spill(keeps%lclosest, discards%lclosest, lspill_list, ldestructive) - call swiftest_util_spill(keeps%status, discards%status, lspill_list, ldestructive) - call swiftest_util_spill(keeps%index1, discards%index1, lspill_list, ldestructive) - call swiftest_util_spill(keeps%index2, discards%index2, lspill_list, ldestructive) - call swiftest_util_spill(keeps%id1, discards%id1, lspill_list, ldestructive) - call swiftest_util_spill(keeps%id2, discards%id2, lspill_list, ldestructive) - call swiftest_util_spill(keeps%r1, discards%r1, lspill_list, ldestructive) - call swiftest_util_spill(keeps%r2, discards%r2, lspill_list, ldestructive) - call swiftest_util_spill(keeps%v1, discards%v1, lspill_list, ldestructive) - call swiftest_util_spill(keeps%v2, discards%v2, lspill_list, ldestructive) - call swiftest_util_spill(keeps%level, discards%level, lspill_list, ldestructive) + call util_spill(keeps%tcollision, discards%tcollision, lspill_list, ldestructive) + call util_spill(keeps%lvdotr, discards%lvdotr, lspill_list, ldestructive) + call util_spill(keeps%lclosest, discards%lclosest, lspill_list, ldestructive) + call util_spill(keeps%status, discards%status, lspill_list, ldestructive) + call util_spill(keeps%index1, discards%index1, lspill_list, ldestructive) + call util_spill(keeps%index2, discards%index2, lspill_list, ldestructive) + call util_spill(keeps%id1, discards%id1, lspill_list, ldestructive) + call util_spill(keeps%id2, discards%id2, lspill_list, ldestructive) + call util_spill(keeps%r1, discards%r1, lspill_list, ldestructive) + call util_spill(keeps%r2, discards%r2, lspill_list, ldestructive) + call util_spill(keeps%v1, discards%v1, lspill_list, ldestructive) + call util_spill(keeps%v2, discards%v2, lspill_list, ldestructive) + call util_spill(keeps%level, discards%level, lspill_list, ldestructive) nenc_old = keeps%nenc diff --git a/src/fraggle/fraggle_util.f90 b/src/fraggle/fraggle_util.f90 index 14a3b69df..3b0c42d6a 100644 --- a/src/fraggle/fraggle_util.f90 +++ b/src/fraggle/fraggle_util.f90 @@ -188,8 +188,8 @@ module subroutine fraggle_util_set_mass_dist(self, param) end if ! Sort the distribution in descending order by mass so that the largest fragment is always the first - call swiftest_util_sort(-mass, ind) - call swiftest_util_sort_rearrange(mass, ind, nfrag) + call util_sort(-mass, ind) + call util_sort_rearrange(mass, ind, nfrag) call move_alloc(mass, fragments%mass) fragments%Gmass(:) = G * fragments%mass(:) diff --git a/src/globals/globals_module.f90 b/src/globals/globals_module.f90 index fa6b18582..fd26b3404 100644 --- a/src/globals/globals_module.f90 +++ b/src/globals/globals_module.f90 @@ -102,7 +102,11 @@ module globals !> Standard file names integer(I4B), parameter :: NDUMPFILES = 2 character(*), parameter :: PARAM_RESTART_FILE = "param.restart.in" - character(*), parameter :: SWIFTEST_LOG_FILE = "swiftest.log" !! Name of file to use to log output when using "COMPACT" display style +#ifdef COARRAY + character(STRMAX) :: SWIFTEST_LOG_FILE !! Name of file to use to log output when using "COMPACT" or "PROGRESS" display style (each co-image gets its own log file) +#else + character(*), parameter :: SWIFTEST_LOG_FILE = "swiftest.log" !! Name of file to use to log output when using "COMPACT" or "PROGRESS" display style +#endif integer(I4B), parameter :: SWIFTEST_LOG_OUT = 33 !! File unit for log file when using "COMPACT" display style !> Default file names that can be changed by the user in the parameters file diff --git a/src/helio/helio_module.f90 b/src/helio/helio_module.f90 index cd5581837..182512e53 100644 --- a/src/helio/helio_module.f90 +++ b/src/helio/helio_module.f90 @@ -165,10 +165,11 @@ module subroutine helio_kick_vb_tp(self, nbody_system, param, t, dt, lbeg) logical, intent(in) :: lbeg !! Logical flag indicating whether this is the beginning of the half step or not. end subroutine helio_kick_vb_tp - module subroutine helio_util_setup_initialize_system(self, param) + module subroutine helio_util_setup_initialize_system(self, system_history, param) implicit none - class(helio_nbody_system), intent(inout) :: self !! Helio nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(helio_nbody_system), intent(inout) :: self !! Helio nbody system object + class(swiftest_storage), allocatable, intent(inout) :: system_history !! Stores the system history between output dumps + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters end subroutine helio_util_setup_initialize_system module subroutine helio_step_pl(self, nbody_system, param, t, dt) diff --git a/src/helio/helio_util.f90 b/src/helio/helio_util.f90 index 94b464502..bb032defb 100644 --- a/src/helio/helio_util.f90 +++ b/src/helio/helio_util.f90 @@ -11,17 +11,18 @@ use swiftest contains - module subroutine helio_util_setup_initialize_system(self, param) + module subroutine helio_util_setup_initialize_system(self, system_history, param) !! author: David A. Minton !! !! Initialize a Helio nbody system from files, converting all heliocentric quantities to barycentric. !! implicit none ! Arguments - class(helio_nbody_system), intent(inout) :: self !! Helio nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(helio_nbody_system), intent(inout) :: self !! Helio nbody system object + class(swiftest_storage), allocatable, intent(inout) :: system_history !! Stores the system history between output dumps + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - call swiftest_util_setup_initialize_system(self, param) + call swiftest_util_setup_initialize_system(self, system_history, param) call self%pl%sort("mass", ascending=.false.) call self%pl%vh2vb(self%cb) call self%tp%h2b(self%cb) diff --git a/src/netcdf_io/netcdf_io_implementations.f90 b/src/netcdf_io/netcdf_io_implementations.f90 index c59acd0fc..40c561183 100644 --- a/src/netcdf_io/netcdf_io_implementations.f90 +++ b/src/netcdf_io/netcdf_io_implementations.f90 @@ -37,9 +37,12 @@ module subroutine netcdf_io_close(self) implicit none ! Arguments class(netcdf_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset + character(namelen) :: message if (self%lfile_is_open) then - call netcdf_io_check( nf90_close(self%id), "netcdf_io_close" ) + write(message,*) this_image() + message = "netcdf_io_close on image " // trim(adjustl(message)) + call netcdf_io_check( nf90_close(self%id), message) self%lfile_is_open = .false. end if @@ -59,6 +62,7 @@ module subroutine netcdf_io_find_tslot(self, t, tslot) integer(I4B), intent(out) :: tslot !! The index of the time slot where this data belongs ! Internals real(DP), dimension(:), allocatable :: tvals + integer(I4B) :: i if (.not.self%lfile_is_open) return @@ -68,13 +72,18 @@ module subroutine netcdf_io_find_tslot(self, t, tslot) if (self%max_tslot > 0) then allocate(tvals(self%max_tslot)) call netcdf_io_check( nf90_get_var(self%id, self%time_varid, tvals(:), start=[1]), "netcdf_io_find_tslot get_var" ) + where(tvals(:) /= tvals(:)) tvals(:) = huge(1.0_DP) else allocate(tvals(1)) - tvals(1) = -huge(1.0_DP) + tvals(1) = huge(1.0_DP) + self%max_tslot = 1 end if - tslot = findloc(tvals, t, dim=1) - if (tslot == 0) tslot = self%max_tslot + 1 + tslot = 1 + do i = 1, self%max_tslot + if (t <= tvals(tslot)) exit + tslot = tslot + 1 + end do self%max_tslot = max(self%max_tslot, tslot) self%tslot = tslot @@ -99,16 +108,16 @@ module subroutine netcdf_io_find_idslot(self, id, idslot) if (.not.allocated(self%idvals)) call self%get_idvals() self%max_idslot = size(self%idvals) - idslot = findloc(self%idvals, id, dim=1) - if (idslot == 0) then - self%max_idslot = self%max_idslot + 1 - idslot = self%max_idslot + idslot = id + 1 + if (idslot > self%max_idslot) then ! Update the idvals array allocate(idvals(idslot)) - idvals(1:idslot-1) = self%idvals(1:idslot-1) + idvals(:) = NF90_FILL_INT + idvals(1:self%max_idslot) = self%idvals(1:self%max_idslot) idvals(idslot) = id call move_alloc(idvals, self%idvals) + self%max_idslot = idslot end if self%idslot = idslot diff --git a/src/rmvs/rmvs_coarray.f90 b/src/rmvs/rmvs_coarray.f90 new file mode 100644 index 000000000..6f7467df8 --- /dev/null +++ b/src/rmvs/rmvs_coarray.f90 @@ -0,0 +1,177 @@ +!! Copyright 2023 - David Minton +!! This file is part of Swiftest. +!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License +!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. +!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty +!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. +!! You should have received a copy of the GNU General Public License along with Swiftest. +!! If not, see: https://www.gnu.org/licenses. + +submodule (rmvs) s_rmvs_coarray +use coarray +use swiftest +use whm +contains + + module subroutine rmvs_coarray_coclone_cb(self) + !! author: David A. Minton + !! + !! Broadcasts the image 1 object to all other images in a coarray + implicit none + ! Arguments + class(rmvs_cb),intent(inout),codimension[*] :: self !! RMVS pl object + + call coclone(self%outer) + call coclone(self%inner) + call coclone(self%lplanetocentric) + + call swiftest_coarray_coclone_cb(self) + + return + end subroutine rmvs_coarray_coclone_cb + + + module subroutine rmvs_coarray_coclone_interp(self) + !! author: David A. Minton + !! + !! Broadcasts the image 1 object to all other images in a coarray + implicit none + ! Arguments + class(rmvs_interp),intent(inout),codimension[*] :: self !! RMVS pl object + + call coclone(self%x) + call coclone(self%v) + call coclone(self%aobl) + call coclone(self%atide) + + return + end subroutine rmvs_coarray_coclone_interp + + + module subroutine rmvs_coarray_coclone_pl(self) + !! author: David A. Minton + !! + !! Broadcasts the image 1 object to all other images in a coarray + implicit none + ! Arguments + class(rmvs_pl),intent(inout),codimension[*] :: self !! RMVS pl object + + call coclone(self%nenc) + call coclone(self%tpenc1P) + call coclone(self%plind) + call coclone(self%outer) + call coclone(self%lplanetocentric) + + call whm_coarray_coclone_pl(self) + + return + end subroutine rmvs_coarray_coclone_pl + + + + module subroutine rmvs_coarray_coclone_system(self) + !! author: David A. Minton + !! + !! Broadcasts the image 1 object to all other images in a coarray + implicit none + ! Arguments + class(rmvs_nbody_system),intent(inout),codimension[*] :: self !! Swiftest body object + ! Internals + integer(I4B) :: i, img + + call coclone(self%lplanetocentric) + call coclone(self%rts) + call coclone(self%vbeg) + + call swiftest_coarray_coclone_system(self) + + return + end subroutine rmvs_coarray_coclone_system + + + module subroutine rmvs_coarray_coclone_tp(self) + !! author: David A. Minton + !! + !! Broadcasts the image 1 object to all other images in a coarray + implicit none + ! Arguments + class(rmvs_tp),intent(inout),codimension[*] :: self !! RMVS pl object + + call coclone(self%lperi) + call coclone(self%plperP) + call coclone(self%plencP) + call coclone(self%index) + call coclone(self%ipleP) + call coclone(self%lplanetocentric) + + call swiftest_coarray_coclone_tp(self) + + return + end subroutine rmvs_coarray_coclone_tp + + + module subroutine rmvs_coarray_component_clone_interp_arr1D(var,src_img) + implicit none + !! author: David A. Minton + !! + !! Copies a component of a coarray derived type from the specified source image to the current local one. The default source image is 1 + !! swiftest_particle_info scalar version + ! Arguments + type(rmvs_interp), dimension(:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + ! Internals + type(rmvs_interp), dimension(:), codimension[:], allocatable :: tmp + integer(I4B) :: i,img, si + integer(I4B), save :: n[*] + logical, save :: isalloc[*] + + if (present(src_img)) then + si = src_img + else + si = 1 + end if + + sync all + isalloc = allocated(var) + if (isalloc) n = size(var) + sync all + if (.not. isalloc[si]) return + + allocate(tmp(n[si])[*]) + do i = 1, n[si] + call tmp(i)%coclone() + end do + if (this_image() == si) then + do img = 1, num_images() + tmp(:)[img] = var(:) + end do + + sync images(*) + else + sync images(si) + if (allocated(var)) deallocate(var) + allocate(var, source=tmp) + end if + + return + end subroutine rmvs_coarray_component_clone_interp_arr1D + + + module subroutine rmvs_coarray_cocollect_tp(self) + !! author: David A. Minton + !! + !! Broadcasts the image 1 object to all other images in a coarray + implicit none + ! Arguments + class(rmvs_tp),intent(inout),codimension[*] :: self !! RMVS pl object + + call cocollect(self%lperi) + call cocollect(self%plperP) + call cocollect(self%plencP) + + call swiftest_coarray_cocollect_tp(self) + + return + end subroutine rmvs_coarray_cocollect_tp + +end submodule s_rmvs_coarray \ No newline at end of file diff --git a/src/rmvs/rmvs_discard.f90 b/src/rmvs/rmvs_discard.f90 index 7e0cb9905..bb6c3063e 100644 --- a/src/rmvs/rmvs_discard.f90 +++ b/src/rmvs/rmvs_discard.f90 @@ -54,6 +54,9 @@ module subroutine rmvs_discard_tp(self, nbody_system, param) call swiftest_discard_tp(tp, nbody_system, param) end associate + + return + end subroutine rmvs_discard_tp end submodule s_rmvs_discard \ No newline at end of file diff --git a/src/rmvs/rmvs_module.f90 b/src/rmvs/rmvs_module.f90 index 733a81e60..b219fd01b 100644 --- a/src/rmvs/rmvs_module.f90 +++ b/src/rmvs/rmvs_module.f90 @@ -35,6 +35,9 @@ module rmvs procedure :: dealloc => rmvs_util_dealloc_system !! Performs RMVS-specific deallocation procedure :: initialize => rmvs_util_setup_initialize_system !! Performs RMVS-specific initilization steps, including generating the close encounter planetocentric structures procedure :: step => rmvs_step_system !! Advance the RMVS nbody system forward in time by one step +#ifdef COARRAY + procedure :: coclone => rmvs_coarray_coclone_system !! Clones the image 1 body object to all other images in the coarray structure. +#endif end type rmvs_nbody_system type, private :: rmvs_interp @@ -45,6 +48,9 @@ module rmvs contains procedure :: dealloc => rmvs_util_dealloc_interp !! Deallocates all allocatable arrays final :: rmvs_final_interp !! Finalizes the RMVS interpolated nbody_system variables object - deallocates all allocatables +#ifdef COARRAY + procedure :: coclone => rmvs_coarray_coclone_interp +#endif end type rmvs_interp @@ -56,6 +62,9 @@ module rmvs contains procedure :: dealloc => rmvs_util_dealloc_cb !! Deallocates all allocatable arrays final :: rmvs_final_cb !! Finalizes the RMVS central body object - deallocates all allocatables +#ifdef COARRAY + procedure :: coclone => rmvs_coarray_coclone_cb !! Clones the image 1 body object to all other images in the coarray structure. +#endif end type rmvs_cb @@ -88,6 +97,10 @@ module rmvs procedure :: rearrange => rmvs_util_sort_rearrange_tp !! Rearranges the order of array elements of body based on an input index array. Used in sorting methods procedure :: spill => rmvs_util_spill_tp !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) final :: rmvs_final_tp !! Finalizes the RMVS test particle object - deallocates all allocatables +#ifdef COARRAY + procedure :: coclone => rmvs_coarray_coclone_tp !! Clones the image 1 body object to all other images in the coarray structure. + procedure :: cocollect => rmvs_coarray_cocollect_tp !! Clones the image 1 body object to all other images in the coarray structure. +#endif end type rmvs_tp @@ -101,7 +114,7 @@ module rmvs class(rmvs_nbody_system), dimension(:), allocatable :: planetocentric !! Planetocentric version of the massive body objects (one for each massive body) logical :: lplanetocentric = .false. !! Flag that indicates that the object is a planetocentric set of masive bodies used for close encounter calculations contains - procedure :: setup => rmvs_util_setup_pl !! Constructor method - Allocates space for the input number of bodiess + procedure :: setup => rmvs_util_setup_pl !! Constructor method - Allocates space for the input number of bodiess procedure :: append => rmvs_util_append_pl !! Appends elements from one structure to another procedure :: dealloc => rmvs_util_dealloc_pl !! Deallocates all allocatable arrays procedure :: fill => rmvs_util_fill_pl !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) @@ -109,7 +122,10 @@ module rmvs procedure :: sort => rmvs_util_sort_pl !! Sorts body arrays by a sortable componen procedure :: rearrange => rmvs_util_sort_rearrange_pl !! Rearranges the order of array elements of body based on an input index array. Used in sorting methods procedure :: spill => rmvs_util_spill_pl !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) - final :: rmvs_final_pl !! Finalizes the RMVS massive body object - deallocates all allocatables + final :: rmvs_final_pl !! Finalizes the RMVS massive body object - deallocates all allocatables +#ifdef COARRAY + procedure :: coclone => rmvs_coarray_coclone_pl !! Clones the image 1 body object to all other images in the coarray structure. +#endif end type rmvs_pl interface @@ -145,10 +161,11 @@ module subroutine rmvs_util_setup_pl(self, n, param) class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters end subroutine rmvs_util_setup_pl - module subroutine rmvs_util_setup_initialize_system(self, param) + module subroutine rmvs_util_setup_initialize_system(self, system_history, param) implicit none - class(rmvs_nbody_system), intent(inout) :: self !! RMVS system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(rmvs_nbody_system), intent(inout) :: self !! RMVS system object + class(swiftest_storage), allocatable, intent(inout) :: system_history !! Stores the system history between output dumps + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters end subroutine rmvs_util_setup_initialize_system module subroutine rmvs_util_setup_tp(self, n, param) @@ -275,6 +292,51 @@ end subroutine rmvs_step_system end interface + +#ifdef COARRAY + interface coclone + module subroutine rmvs_coarray_component_clone_interp_arr1D(var,src_img) + implicit none + type(rmvs_interp), dimension(:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + end subroutine rmvs_coarray_component_clone_interp_arr1D + end interface + + interface cocollect + module subroutine rmvs_coarray_cocollect_tp(self) + implicit none + class(rmvs_tp),intent(inout),codimension[*] :: self !! RMVS pl object + end subroutine rmvs_coarray_cocollect_tp + end interface + + interface + module subroutine rmvs_coarray_coclone_cb(self) + implicit none + class(rmvs_cb),intent(inout),codimension[*] :: self !! RMVS tp object + end subroutine rmvs_coarray_coclone_cb + + module subroutine rmvs_coarray_coclone_interp(self) + implicit none + class(rmvs_interp),intent(inout),codimension[*] :: self !! RMVS tp object + end subroutine rmvs_coarray_coclone_interp + + module subroutine rmvs_coarray_coclone_pl(self) + implicit none + class(rmvs_pl),intent(inout),codimension[*] :: self !! RMVS pl object + end subroutine rmvs_coarray_coclone_pl + + module subroutine rmvs_coarray_coclone_system(self) + implicit none + class(rmvs_nbody_system),intent(inout),codimension[*] :: self !! RMVS nbody system object + end subroutine rmvs_coarray_coclone_system + + module subroutine rmvs_coarray_coclone_tp(self) + implicit none + class(rmvs_tp),intent(inout),codimension[*] :: self !! RMVS tp object + end subroutine rmvs_coarray_coclone_tp + end interface +#endif + contains subroutine rmvs_final_cb(self) diff --git a/src/rmvs/rmvs_util.f90 b/src/rmvs/rmvs_util.f90 index b9462840b..224ba2cd1 100644 --- a/src/rmvs/rmvs_util.f90 +++ b/src/rmvs/rmvs_util.f90 @@ -24,19 +24,17 @@ module subroutine rmvs_util_append_pl(self, source, lsource_mask) select type(source) class is (rmvs_pl) - associate(nold => self%nbody, nsrc => source%nbody) - call swiftest_util_append(self%nenc, source%nenc, nold, nsrc, lsource_mask) - call swiftest_util_append(self%tpenc1P, source%tpenc1P, nold, nsrc, lsource_mask) - call swiftest_util_append(self%plind, source%plind, nold, nsrc, lsource_mask) + call util_append(self%nenc, source%nenc, lsource_mask=lsource_mask) + call util_append(self%tpenc1P, source%tpenc1P, lsource_mask=lsource_mask) + call util_append(self%plind, source%plind, lsource_mask=lsource_mask) - ! The following are not implemented as RMVS doesn't make use of fill operations on pl type - ! So they are here as a placeholder in case someone wants to extend the RMVS class for some reason - !call swiftest_util_append(self%outer, source%outer, nold, nsrc, lsource_mask) - !call swiftest_util_append(self%inner, source%inner, nold, nsrc, lsource_mask) - !call swiftest_util_append(self%planetocentric, source%planetocentric, nold, nsrc, lsource_mask) + ! The following are not implemented as RMVS doesn't make use of fill operations on pl type + ! So they are here as a placeholder in case someone wants to extend the RMVS class for some reason + !call util_append(self%outer, source%outer, lsource_mask=lsource_mask) + !call util_append(self%inner, source%inner, lsource_mask=lsource_mask) + !call util_append(self%planetocentric, source%planetocentric, lsource_mask) - call whm_util_append_pl(self, source, lsource_mask) - end associate + call whm_util_append_pl(self, source, lsource_mask) class default write(*,*) "Invalid object passed to the append method. Source must be of class rmvs_pl or its descendents!" call base_util_exit(FAILURE) @@ -59,13 +57,11 @@ module subroutine rmvs_util_append_tp(self, source, lsource_mask) select type(source) class is (rmvs_tp) - associate(nold => self%nbody, nsrc => source%nbody) - call swiftest_util_append(self%lperi, source%lperi, nold, nsrc, lsource_mask) - call swiftest_util_append(self%plperP, source%plperP, nold, nsrc, lsource_mask) - call swiftest_util_append(self%plencP, source%plencP, nold, nsrc, lsource_mask) + call util_append(self%lperi, source%lperi, lsource_mask=lsource_mask) + call util_append(self%plperP, source%plperP, lsource_mask=lsource_mask) + call util_append(self%plencP, source%plencP, lsource_mask=lsource_mask) - call swiftest_util_append_tp(self, source, lsource_mask) ! Note: whm_tp does not have its own append method, so we skip back to the base class - end associate + call swiftest_util_append_tp(self, source, lsource_mask) ! Note: whm_tp does not have its own append method, so we skip back to the base class class default write(*,*) "Invalid object passed to the append method. Source must be of class rmvs_tp or its descendents!" call base_util_exit(FAILURE) @@ -177,15 +173,15 @@ module subroutine rmvs_util_fill_pl(self, inserts, lfill_list) associate(keeps => self) select type(inserts) class is (rmvs_pl) - call swiftest_util_fill(keeps%nenc, inserts%nenc, lfill_list) - call swiftest_util_fill(keeps%tpenc1P, inserts%tpenc1P, lfill_list) - call swiftest_util_fill(keeps%plind, inserts%plind, lfill_list) + call util_fill(keeps%nenc, inserts%nenc, lfill_list) + call util_fill(keeps%tpenc1P, inserts%tpenc1P, lfill_list) + call util_fill(keeps%plind, inserts%plind, lfill_list) ! The following are not implemented as RMVS doesn't make use of fill operations on pl type ! So they are here as a placeholder in case someone wants to extend the RMVS class for some reason - !call swiftest_util_fill(keeps%outer, inserts%outer, lfill_list) - !call swiftest_util_fill(keeps%inner, inserts%inner, lfill_list) - !call swiftest_util_fill(keeps%planetocentric, inserts%planetocentric, lfill_list) + !call util_fill(keeps%outer, inserts%outer, lfill_list) + !call util_fill(keeps%inner, inserts%inner, lfill_list) + !call util_fill(keeps%planetocentric, inserts%planetocentric, lfill_list) call whm_util_fill_pl(keeps, inserts, lfill_list) class default @@ -213,9 +209,9 @@ module subroutine rmvs_util_fill_tp(self, inserts, lfill_list) associate(keeps => self) select type(inserts) class is (rmvs_tp) - call swiftest_util_fill(keeps%lperi, inserts%lperi, lfill_list) - call swiftest_util_fill(keeps%plperP, inserts%plperP, lfill_list) - call swiftest_util_fill(keeps%plencP, inserts%plencP, lfill_list) + call util_fill(keeps%lperi, inserts%lperi, lfill_list) + call util_fill(keeps%plperP, inserts%plperP, lfill_list) + call util_fill(keeps%plencP, inserts%plencP, lfill_list) call swiftest_util_fill_tp(keeps, inserts, lfill_list) ! Note: whm_tp does not have its own fill method, so we skip back to the base class class default @@ -237,15 +233,15 @@ module subroutine rmvs_util_resize_pl(self, nnew) class(rmvs_pl), intent(inout) :: self !! RMVS massive body object integer(I4B), intent(in) :: nnew !! New size neded - call swiftest_util_resize(self%nenc, nnew) - call swiftest_util_resize(self%tpenc1P, nnew) - call swiftest_util_resize(self%plind, nnew) + call util_resize(self%nenc, nnew) + call util_resize(self%tpenc1P, nnew) + call util_resize(self%plind, nnew) ! The following are not implemented as RMVS doesn't make use of resize operations on pl type ! So they are here as a placeholder in case someone wants to extend the RMVS class for some reason - !call swiftest_util_resize(self%outer, nnew) - !call swiftest_util_resize(self%inner, nnew) - !call swiftest_util_resize(self%planetocentric, nnew) + !call util_resize(self%outer, nnew) + !call util_resize(self%inner, nnew) + !call util_resize(self%planetocentric, nnew) call whm_util_resize_pl(self, nnew) return @@ -261,10 +257,10 @@ module subroutine rmvs_util_resize_tp(self, nnew) class(rmvs_tp), intent(inout) :: self !! RMVS test particle object integer(I4B), intent(in) :: nnew !! New size neded - call swiftest_util_resize(self%lperi, nnew) - call swiftest_util_resize(self%plperP, nnew) - call swiftest_util_resize(self%plencP, nnew) - call swiftest_util_resize(self%rheliocentric, nnew) + call util_resize(self%lperi, nnew) + call util_resize(self%plperP, nnew) + call util_resize(self%plencP, nnew) + call util_resize(self%rheliocentric, nnew) call swiftest_util_resize_tp(self, nnew) @@ -323,7 +319,7 @@ module subroutine rmvs_util_setup_pl(self, n, param) end subroutine rmvs_util_setup_pl - module subroutine rmvs_util_setup_initialize_system(self, param) + module subroutine rmvs_util_setup_initialize_system(self, system_history, param) !! author: David A. Minton !! !! Initialize an RMVS nbody system from files and sets up the planetocentric structures. @@ -335,13 +331,14 @@ module subroutine rmvs_util_setup_initialize_system(self, param) !! to use during close encounters. implicit none ! Arguments - class(rmvs_nbody_system), intent(inout) :: self !! RMVS system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(rmvs_nbody_system), intent(inout) :: self !! RMVS system object + class(swiftest_storage), allocatable, intent(inout) :: system_history !! Stores the system history between output dumps + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters ! Internals integer(I4B) :: i, j ! Call parent method - call whm_util_setup_initialize_system(self, param) + call whm_util_setup_initialize_system(self, system_history, param) ! Set up the pl-tp planetocentric encounter structures for pl and cb. The planetocentric tp structures are ! generated as necessary during close encounter steps. @@ -413,11 +410,13 @@ module subroutine rmvs_util_setup_tp(self, n, param) call self%whm_tp%setup(n, param) if (n <= 0) return - allocate(self%lperi(n)) - allocate(self%plperP(n)) - allocate(self%plencP(n)) + if (allocated(self%lperi)) deallocate(self%lperi); allocate(self%lperi(n)) + if (allocated(self%plperP)) deallocate(self%plperP); allocate(self%plperP(n)) + if (allocated(self%plencP)) deallocate(self%plencP); allocate(self%plencP(n)) - if (self%lplanetocentric) allocate(self%rheliocentric(NDIM, n)) + if (self%lplanetocentric) then + if (allocated(self%rheliocentric)) deallocate(self%rheliocentric); allocate(self%rheliocentric(NDIM, n)) + end if self%lperi(:) = .false. @@ -450,11 +449,11 @@ module subroutine rmvs_util_sort_pl(self, sortby, ascending) associate(pl => self, npl => self%nbody) select case(sortby) case("nenc") - call swiftest_util_sort(direction * pl%nenc(1:npl), ind) + call util_sort(direction * pl%nenc(1:npl), ind) case("tpenc1P") - call swiftest_util_sort(direction * pl%tpenc1P(1:npl), ind) + call util_sort(direction * pl%tpenc1P(1:npl), ind) case("plind") - call swiftest_util_sort(direction * pl%plind(1:npl), ind) + call util_sort(direction * pl%plind(1:npl), ind) case("outer", "inner", "planetocentric", "lplanetocentric") write(*,*) 'Cannot sort by ' // trim(adjustl(sortby)) // '. Component not sortable!' case default ! Look for components in the parent class @@ -494,9 +493,9 @@ module subroutine rmvs_util_sort_tp(self, sortby, ascending) associate(tp => self, ntp => self%nbody) select case(sortby) case("plperP") - call swiftest_util_sort(direction * tp%plperP(1:ntp), ind) + call util_sort(direction * tp%plperP(1:ntp), ind) case("plencP") - call swiftest_util_sort(direction * tp%plencP(1:ntp), ind) + call util_sort(direction * tp%plencP(1:ntp), ind) case("lperi", "cb_heliocentric", "rheliocentric", "index", "ipleP", "lplanetocentric") write(*,*) 'Cannot sort by ' // trim(adjustl(sortby)) // '. Component not sortable!' case default ! Look for components in the parent class (*NOTE whm_tp does not need its own sort method, so we go straight to the swiftest_tp method) @@ -523,9 +522,9 @@ module subroutine rmvs_util_sort_rearrange_pl(self, ind) if (self%nbody == 0) return associate(pl => self, npl => self%nbody) - call swiftest_util_sort_rearrange(pl%nenc, ind, npl) - call swiftest_util_sort_rearrange(pl%tpenc1P, ind, npl) - call swiftest_util_sort_rearrange(pl%plind, ind, npl) + call util_sort_rearrange(pl%nenc, ind, npl) + call util_sort_rearrange(pl%tpenc1P, ind, npl) + call util_sort_rearrange(pl%plind, ind, npl) call swiftest_util_sort_rearrange_pl(pl,ind) end associate @@ -546,10 +545,10 @@ module subroutine rmvs_util_sort_rearrange_tp(self, ind) if (self%nbody == 0) return associate(tp => self, ntp => self%nbody) - call swiftest_util_sort_rearrange(tp%lperi, ind, ntp) - call swiftest_util_sort_rearrange(tp%plperP, ind, ntp) - call swiftest_util_sort_rearrange(tp%plencP, ind, ntp) - call swiftest_util_sort_rearrange(tp%rheliocentric, ind, ntp) + call util_sort_rearrange(tp%lperi, ind, ntp) + call util_sort_rearrange(tp%plperP, ind, ntp) + call util_sort_rearrange(tp%plencP, ind, ntp) + call util_sort_rearrange(tp%rheliocentric, ind, ntp) call swiftest_util_sort_rearrange_tp(tp,ind) end associate @@ -573,9 +572,9 @@ module subroutine rmvs_util_spill_pl(self, discards, lspill_list, ldestructive) associate(keeps => self) select type(discards) class is (rmvs_pl) - call swiftest_util_spill(keeps%nenc, discards%nenc, lspill_list, ldestructive) - call swiftest_util_spill(keeps%tpenc1P, discards%tpenc1P, lspill_list, ldestructive) - call swiftest_util_spill(keeps%plind, discards%plind, lspill_list, ldestructive) + call util_spill(keeps%nenc, discards%nenc, lspill_list, ldestructive) + call util_spill(keeps%tpenc1P, discards%tpenc1P, lspill_list, ldestructive) + call util_spill(keeps%plind, discards%plind, lspill_list, ldestructive) call whm_util_spill_pl(keeps, discards, lspill_list, ldestructive) class default @@ -604,9 +603,9 @@ module subroutine rmvs_util_spill_tp(self, discards, lspill_list, ldestructive) associate(keeps => self) select type(discards) class is (rmvs_tp) - call swiftest_util_spill(keeps%lperi, discards%lperi, lspill_list, ldestructive) - call swiftest_util_spill(keeps%plperP, discards%plperP, lspill_list, ldestructive) - call swiftest_util_spill(keeps%plencP, discards%plencP, lspill_list, ldestructive) + call util_spill(keeps%lperi, discards%lperi, lspill_list, ldestructive) + call util_spill(keeps%plperP, discards%plperP, lspill_list, ldestructive) + call util_spill(keeps%plencP, discards%plencP, lspill_list, ldestructive) call swiftest_util_spill_tp(keeps, discards, lspill_list, ldestructive) class default diff --git a/src/swiftest/swiftest_coarray.f90 b/src/swiftest/swiftest_coarray.f90 new file mode 100644 index 000000000..e35d3d838 --- /dev/null +++ b/src/swiftest/swiftest_coarray.f90 @@ -0,0 +1,712 @@ +!! Copyright 2023 - David Minton +!! This file is part of Swiftest. +!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License +!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. +!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty +!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. +!! You should have received a copy of the GNU General Public License along with Swiftest. +!! If not, see: https://www.gnu.org/licenses. + +submodule (swiftest) s_swiftest_coarray + use coarray +contains + + + module subroutine swiftest_coarray_balance_system(nbody_system, param) + !! author: David A. Minton + !! + !! Checks whether or not the system needs to be rebalance. Rebalancing occurs when the difference between the number of test particles between the + !! image with the smallest and largest number of test particles is larger than the number of images + implicit none + ! Arguments + class(swiftest_nbody_system), intent(inout) :: nbody_system !! Swiftest nbody system + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + ! Internals + integer(I4B), codimension[*], save :: ntp + integer(I4B) :: img,ntp_min, ntp_max + + ntp = nbody_system%tp%nbody + sync all + ntp_min = huge(1) + ntp_max = 0 + do img = 1, num_images() + if (ntp[img] < ntp_min) ntp_min = ntp[img] + if (ntp[img] > ntp_max) ntp_max = ntp[img] + end do + if (ntp_max - ntp_min >= num_images()) then + call nbody_system%coarray_collect(param) + call nbody_system%coarray_distribute(param) + end if + + return + end subroutine swiftest_coarray_balance_system + + module subroutine swiftest_coarray_coclone_body(self) + !! author: David A. Minton + !! + !! Broadcasts the image 1 object to all other images in a coarray + implicit none + ! Arguments + class(swiftest_body),intent(inout),codimension[*] :: self !! Swiftest body object + + call coclone(self%lfirst) + call coclone(self%nbody) + call coclone(self%id) + call coclone(self%info) + call coclone(self%lmask) + call coclone(self%status) + call coclone(self%ldiscard) + call coclone(self%lcollision) + call coclone(self%lencounter) + call coclone(self%mu) + call coclone(self%rh) + call coclone(self%vh) + call coclone(self%rb) + call coclone(self%vb) + call coclone(self%ah) + call coclone(self%aobl) + call coclone(self%agr) + call coclone(self%atide) + call coclone(self%ir3h) + call coclone(self%isperi) + call coclone(self%peri) + call coclone(self%atp) + call coclone(self%a) + call coclone(self%e) + call coclone(self%inc) + call coclone(self%capom) + call coclone(self%omega) + call coclone(self%capm) + + return + end subroutine swiftest_coarray_coclone_body + + module subroutine swiftest_coarray_coclone_nc(self) + !! author: David A. Minton + !! + !! Broadcasts the image 1 object to all other images in a coarray + implicit none + ! Arguments + class(swiftest_netcdf_parameters),intent(inout),codimension[*] :: self !! Swiftest body object + + call coclone(self%file_name) + call coclone(self%lfile_is_open) + call coclone(self%out_type) + call coclone(self%id) + call coclone(self%tslot) + call coclone(self%max_tslot) + call coclone(self%idvals) + call coclone(self%idslot) + call coclone(self%max_idslot) + call coclone(self%str_dimname) + call coclone(self%str_dimid) + call coclone(self%time_dimname) + call coclone(self%time_dimid) + call coclone(self%time_varid) + call coclone(self%name_dimname) + call coclone(self%name_dimid) + call coclone(self%name_varid) + call coclone(self%space_dimname) + call coclone(self%space_dimid) + call coclone(self%space_varid) + call coclone(self%id_varname) + call coclone(self%id_varid) + call coclone(self%status_varname) + call coclone(self%status_varid) + call coclone(self%ptype_varname) + call coclone(self%ptype_varid) + call coclone(self%npl_varname) + call coclone(self%npl_varid) + call coclone(self%ntp_varname) + call coclone(self%ntp_varid) + call coclone(self%nplm_varname) + call coclone(self%nplm_varid) + call coclone(self%a_varname) + call coclone(self%a_varid) + call coclone(self%e_varname) + call coclone(self%e_varid) + call coclone(self%inc_varname) + call coclone(self%inc_varid) + call coclone(self%capom_varname) + call coclone(self%capom_varid) + call coclone(self%omega_varname) + call coclone(self%omega_varid) + call coclone(self%capm_varname) + call coclone(self%capm_varid) + call coclone(self%varpi_varname) + call coclone(self%varpi_varid) + call coclone(self%lam_varname) + call coclone(self%lam_varid) + call coclone(self%f_varname) + call coclone(self%f_varid) + call coclone(self%cape_varname) + call coclone(self%cape_varid) + call coclone(self%rh_varname) + call coclone(self%rh_varid) + call coclone(self%vh_varname) + call coclone(self%vh_varid) + call coclone(self%gr_pseudo_vh_varname) + call coclone(self%gr_pseudo_vh_varid) + call coclone(self%Gmass_varname) + call coclone(self%Gmass_varid) + call coclone(self%mass_varname) + call coclone(self%mass_varid) + call coclone(self%rhill_varname) + call coclone(self%rhill_varid) + call coclone(self%radius_varname) + call coclone(self%radius_varid) + call coclone(self%Ip_varname) + call coclone(self%Ip_varid) + call coclone(self%rot_varname) + call coclone(self%rot_varid) + call coclone(self%j2rp2_varname) + call coclone(self%j2rp2_varid) + call coclone(self%j4rp4_varname) + call coclone(self%j4rp4_varid) + call coclone(self%k2_varname) + call coclone(self%k2_varid) + call coclone(self%q_varname) + call coclone(self%Q_varid) + call coclone(self%ke_orb_varname) + call coclone(self%KE_orb_varid) + call coclone(self%ke_spin_varname) + call coclone(self%KE_spin_varid) + call coclone(self%pe_varname) + call coclone(self%PE_varid) + call coclone(self%be_varname) + call coclone(self%BE_varid) + call coclone(self%te_varname) + call coclone(self%TE_varid) + call coclone(self%L_orbit_varname) + call coclone(self%L_orbit_varid) + call coclone(self%L_spin_varname) + call coclone(self%L_spin_varid) + call coclone(self%L_escape_varname) + call coclone(self%L_escape_varid) + call coclone(self%E_collisions_varname) + call coclone(self%E_collisions_varid) + call coclone(self%E_untracked_varname) + call coclone(self%E_untracked_varid) + call coclone(self%GMescape_varname) + call coclone(self%GMescape_varid) + call coclone(self%origin_type_varname) + call coclone(self%origin_type_varid) + call coclone(self%origin_time_varname) + call coclone(self%origin_time_varid) + call coclone(self%collision_id_varname) + call coclone(self%collision_id_varid) + call coclone(self%origin_rh_varname) + call coclone(self%origin_rh_varid) + call coclone(self%origin_vh_varname) + call coclone(self%origin_vh_varid) + call coclone(self%discard_time_varname) + call coclone(self%discard_time_varid) + call coclone(self%discard_rh_varname) + call coclone(self%discard_rh_varid) + call coclone(self%discard_vh_varname) + call coclone(self%discard_vh_varid) + call coclone(self%discard_body_id_varname) + call coclone(self%lpseudo_vel_exists) + return + end subroutine swiftest_coarray_coclone_nc + + module subroutine swiftest_coarray_coclone_cb(self) + !! author: David A. Minton + !! + !! Broadcasts the image 1 object to all other images in a coarray + implicit none + ! Arguments + class(swiftest_cb),intent(inout),codimension[*] :: self !! Swiftest body object + ! Internals + integer(I4B) :: i + + call coclone(self%info) + call coclone(self%id) + call coclone(self%mass) + call coclone(self%Gmass) + call coclone(self%radius) + call coclone(self%density) + call coclone(self%j2rp2) + call coclone(self%j4rp4) + call coclone(self%k2) + call coclone(self%Q) + call coclone(self%tlag) + call coclone(self%GM0) + call coclone(self%dGM) + call coclone(self%R0) + call coclone(self%dR) + + call coclonevec(self%aobl) + call coclonevec(self%atide) + call coclonevec(self%aoblbeg) + call coclonevec(self%aoblend) + call coclonevec(self%atidebeg) + call coclonevec(self%atideend) + call coclonevec(self%rb) + call coclonevec(self%vb) + call coclonevec(self%agr) + call coclonevec(self%Ip) + call coclonevec(self%rot) + call coclonevec(self%L0) + call coclonevec(self%dL) + + return + end subroutine swiftest_coarray_coclone_cb + + + module subroutine swiftest_coarray_coclone_pl(self) + !! author: David A. Minton + !! + !! Broadcasts the image 1 object to all other images in a coarray + implicit none + ! Arguments + class(swiftest_pl),intent(inout),codimension[*] :: self !! Swiftest body object + + call coclone(self%mass) + call coclone(self%Gmass) + call coclone(self%rhill) + call coclone(self%renc) + call coclone(self%radius) + call coclone(self%density) + call coclone(self%rbeg) + call coclone(self%rend) + call coclone(self%vbeg) + call coclone(self%Ip) + call coclone(self%rot) + call coclone(self%k2) + call coclone(self%Q ) + call coclone(self%tlag) + call coclone(self%kin) + call coclone(self%lmtiny) + call coclone(self%nplm) + call coclone(self%nplplm) + call coclone(self%nplenc) + call coclone(self%ntpenc) + + call swiftest_coarray_coclone_body(self) + + return + end subroutine swiftest_coarray_coclone_pl + + + module subroutine swiftest_coarray_coclone_tp(self) + !! author: David A. Minton + !! + !! Broadcasts the image 1 object to all other images in a coarray + implicit none + ! Arguments + class(swiftest_tp),intent(inout),codimension[*] :: self !! Swiftest body object + + call coclone(self%nplenc) + call swiftest_coarray_coclone_body(self) + + return + end subroutine swiftest_coarray_coclone_tp + + + module subroutine swiftest_coarray_coclone_system(self) + !! author: David A. Minton + !! + !! Broadcasts the image 1 object to all other images in a coarray + implicit none + ! Arguments + class(swiftest_nbody_system),intent(inout),codimension[*] :: self !! Swiftest body object + ! Internals + integer(I4B) :: i + + call self%cb%coclone() + call self%pl%coclone() + call self%tp%coclone() + + call coclone(self%maxid) + call coclone(self%t) + call coclone(self%GMtot) + call coclone(self%ke_orbit) + call coclone(self%ke_spin) + call coclone(self%pe) + call coclone(self%be) + call coclone(self%te) + call coclone(self%oblpot) + do i = 1, NDIM + call coclone(self%L_orbit(i)) + call coclone(self%L_spin(i)) + call coclone(self%L_total(i)) + call coclone(self%L_total_orig(i)) + call coclone(self%L_orbit_orig(i)) + call coclone(self%L_spin_orig(i)) + call coclone(self%L_escape(i)) + end do + call coclone(self%ke_orbit_orig) + call coclone(self%ke_spin_orig) + call coclone(self%pe_orig) + call coclone(self%be_orig) + call coclone(self%te_orig) + call coclone(self%be_cb) + call coclone(self%E_orbit_orig) + call coclone(self%GMtot_orig) + call coclone(self%GMescape) + call coclone(self%E_collisions) + call coclone(self%E_untracked) + call coclone(self%ke_orbit_error) + call coclone(self%ke_spin_error) + call coclone(self%pe_error) + call coclone(self%be_error) + call coclone(self%E_orbit_error) + call coclone(self%Ecoll_error) + call coclone(self%E_untracked_error) + call coclone(self%te_error) + call coclone(self%L_orbit_error) + call coclone(self%L_spin_error) + call coclone(self%L_escape_error) + call coclone(self%L_total_error) + call coclone(self%Mtot_error) + call coclone(self%Mescape_error) + call coclone(self%lbeg) + + return + end subroutine swiftest_coarray_coclone_system + + + module subroutine swiftest_coarray_component_clone_info(var,src_img) + !! author: David A. Minton + !! + !! Copies a component of a coarray derived type from the specified source image to the current local one. The default source image is 1 + !! swiftest_particle_info scalar version + implicit none + ! Arguments + type(swiftest_particle_info), intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + ! Internals + type(swiftest_particle_info),allocatable :: tmp[:] + integer(I4B) :: img, si + + allocate(tmp[*]) + if (present(src_img)) then + si = src_img + else + si = 1 + end if + + if (this_image() == si) then + do img = 1, num_images() + tmp[img] = var + end do + sync images(*) + else + sync images(si) + var = tmp[si] + end if + + deallocate(tmp) + + return + end subroutine swiftest_coarray_component_clone_info + + + module subroutine swiftest_coarray_component_clone_info_arr1D(var,src_img) + !! author: David A. Minton + !! + !! Copies a component of a coarray derived type from the specified source image to the current local one. The default source image is 1 + !! swiftest_particle_info 1D allocatable array version + implicit none + ! Arguments + type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + ! Internals + type(swiftest_particle_info), dimension(:), codimension[:], allocatable :: tmp + integer(I4B) :: img, si + integer(I4B), allocatable :: n[:] + logical, allocatable :: isalloc[:] + + allocate(isalloc[*]) + allocate(n[*]) + + if (present(src_img)) then + si = src_img + else + si = 1 + end if + + isalloc = allocated(var) + if (isalloc) n = size(var) + sync all + if (.not. isalloc[si]) return + + allocate(tmp(n[si])[*]) + if (this_image() == si) then + do img = 1, num_images() + tmp(:)[img] = var + end do + sync images(*) + else + sync images(si) + if (allocated(var)) deallocate(var) + allocate(var, source=tmp) + end if + + deallocate(isalloc,n,tmp) + + return + end subroutine swiftest_coarray_component_clone_info_arr1D + + + module subroutine swiftest_coarray_component_clone_kin_arr1D(var,src_img) + implicit none + !! author: David A. Minton + !! + !! Copies a component of a coarray derived type from the specified source image to the current local one. The default source image is 1 + !! swiftest_kinship allocatable array version + ! Arguments + type(swiftest_kinship), dimension(:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + ! Internals + type(swiftest_kinship), dimension(:), codimension[:], allocatable :: tmp + integer(I4B) :: img, si + integer(I4B), allocatable :: n[:] + logical, allocatable :: isalloc[:] + + if (present(src_img)) then + si = src_img + else + si = 1 + end if + + allocate(isalloc[*]) + allocate(n[*]) + isalloc = allocated(var) + if (isalloc) n = size(var) + sync all + if (.not. isalloc[si]) return + + allocate(tmp(n[si])[*]) + if (this_image() == si) then + do img = 1, num_images() + tmp(:)[img] = var + end do + sync images(*) + else + sync images(si) + if (allocated(var)) deallocate(var) + allocate(var, source=tmp) + end if + + deallocate(isalloc,n,tmp) + + return + end subroutine swiftest_coarray_component_clone_kin_arr1D + + + module subroutine swiftest_coarray_component_collect_info_arr1D(var,dest_img) + !! author: David A. Minton + !! + !! Collects components of a coarray derived type from all images and combines them into destination image component . The default destination image is 1 + !! swiftest_particle_info 1D allocatable array version + implicit none + ! Arguments + type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: dest_img + ! Internals + type(swiftest_particle_info), dimension(:), codimension[:], allocatable :: tmp + integer(I4B) :: i,img, ti, di, ntot, istart, iend, nmax + integer(I4B), allocatable :: n[:] + logical, allocatable :: isalloc[:] + + allocate(isalloc[*]) + allocate(n[*]) + + if (present(dest_img)) then + di = dest_img + else + di = 1 + end if + + isalloc = allocated(var) + if (isalloc) then + n = size(var) + else + n = 0 + end if + sync all + nmax = 0 + do img = 1, num_images() + if (n[img] > nmax) nmax = n[img] + end do + + allocate(tmp(nmax)[*]) + if (isalloc) tmp(1:n) = var(1:n) + + if (this_image() == di) then + do img = 1, num_images() + if (img /= di) then + call util_append(var, tmp(1:n[img])[img]) + n = n + n[img] + end if + end do + sync images(*) + else + sync images(di) + if (allocated(var)) deallocate(var) + end if + + deallocate(isalloc,n,tmp) + + return + end subroutine swiftest_coarray_component_collect_info_arr1D + + + module subroutine swiftest_coarray_cocollect_body(self) + !! author: David A. Minton + !! + !! Collects all body object array components from all images and combines them into the image 1 body object + implicit none + ! Arguments + class(swiftest_body),intent(inout), codimension[*] :: self !! Swiftest body object + integer(I4B) :: i + + call cocollect(self%nbody) + call cocollect(self%id) + call cocollect(self%info) + call cocollect(self%lmask) + call cocollect(self%status) + call cocollect(self%ldiscard) + call cocollect(self%lcollision) + call cocollect(self%lencounter) + call cocollect(self%mu) + call cocollect(self%rh) + call cocollect(self%vh) + call cocollect(self%rb) + call cocollect(self%vb) + call cocollect(self%ah) + call cocollect(self%aobl) + call cocollect(self%agr) + call cocollect(self%atide) + call cocollect(self%ir3h) + call cocollect(self%isperi) + call cocollect(self%peri) + call cocollect(self%atp) + call cocollect(self%a) + call cocollect(self%e) + call cocollect(self%inc) + call cocollect(self%capom) + call cocollect(self%omega) + call cocollect(self%capm) + + return + end subroutine swiftest_coarray_cocollect_body + + + module subroutine swiftest_coarray_cocollect_tp(self) + !! author: David A. Minton + !! + !! Collects all object array components from all images and combines them into the image 1 object + implicit none + ! Arguments + class(swiftest_tp),intent(inout),codimension[*] :: self !! Swiftest body object + + call cocollect(self%npltp) + call cocollect(self%nplenc) + call swiftest_coarray_cocollect_body(self) + + return + end subroutine swiftest_coarray_cocollect_tp + + + module subroutine swiftest_coarray_collect_system(nbody_system, param) + !! author: David A. Minton + !! + !! Collects all the test particles from other images into the image #1 test particle system + implicit none + ! Arguments + class(swiftest_nbody_system), intent(inout) :: nbody_system !! Swiftest nbody system + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + ! Internals + integer(I4B) :: i,j + class(swiftest_tp), allocatable, codimension[:] :: cotp + character(len=NAMELEN) :: image_num_char + + if (.not.param%lcoarray) return + + if (this_image() == 1 .or. param%log_output) then + write(image_num_char,*) num_images() + write(param%display_unit,*) " Collecting test particles from " // trim(adjustl(image_num_char)) // " images." + if (param%log_output) flush(param%display_unit) + end if + + allocate(cotp[*], source=nbody_system%tp) + call cotp%cocollect() + deallocate(nbody_system%tp) + allocate(nbody_system%tp, source=cotp) + + deallocate(cotp) + + return + end subroutine swiftest_coarray_collect_system + + + module subroutine swiftest_coarray_distribute_system(nbody_system, param) + !! author: David A. Minton + !! + !! Distributes test particles from image #1 out to all images. + implicit none + ! Arguments + class(swiftest_nbody_system), intent(inout) :: nbody_system !! Swiftest nbody system + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + ! Internals + integer(I4B) :: istart, iend, ntot, num_per_image, ncopy + logical, dimension(:), allocatable :: lspill_list + integer(I4B), codimension[:], allocatable :: ntp + character(len=NAMELEN) :: image_num_char, ntp_num_char + class(swiftest_tp), allocatable, codimension[:] :: cotp + class(swiftest_tp), allocatable :: tmp + + if (.not.param%lcoarray) return + + allocate(ntp[*]) + ntp = nbody_system%tp%nbody + sync all + ntot = ntp[1] + if (ntot == 0) return + + write(image_num_char,*) num_images() + + if (this_image() == 1 .or. param%log_output) then + write(ntp_num_char,*) ntot + write(param%display_unit,*) " Distributing " // trim(adjustl(ntp_num_char)) // " test particles across " // trim(adjustl(image_num_char)) // " images." + if (param%log_output) flush(param%display_unit) + end if + + allocate(lspill_list(ntot)) + num_per_image = ceiling(1.0_DP * ntot / num_images()) + istart = (this_image() - 1) * num_per_image + 1 + if (this_image() == num_images()) then + iend = ntot + else + iend = this_image() * num_per_image + end if + + lspill_list(:) = .true. + lspill_list(istart:iend) = .false. + + allocate(cotp[*], source=nbody_system%tp) + call cotp%coclone() + if (this_image() /= 1) then + deallocate(nbody_system%tp) + allocate(nbody_system%tp, source=cotp) + end if + allocate(tmp, mold=nbody_system%tp) + call nbody_system%tp%spill(tmp, lspill_list(:), ldestructive=.true.) + + write(image_num_char,*) this_image() + write(ntp_num_char,*) nbody_system%tp%nbody + if (this_image() /= 1) sync images(this_image() - 1) + write(param%display_unit,*) "Image " // trim(adjustl(image_num_char)) // " ntp: " // trim(adjustl(ntp_num_char)) + if (param%log_output) flush(param%display_unit) + if (this_image() < num_images()) sync images(this_image() + 1) + + deallocate(ntp, lspill_list, tmp, cotp) + + return + end subroutine swiftest_coarray_distribute_system + + +end submodule s_swiftest_coarray \ No newline at end of file diff --git a/src/swiftest/swiftest_discard.f90 b/src/swiftest/swiftest_discard.f90 index 6af0c9a8f..dd2f07eab 100644 --- a/src/swiftest/swiftest_discard.f90 +++ b/src/swiftest/swiftest_discard.f90 @@ -25,7 +25,7 @@ module subroutine swiftest_discard_system(self, param) lpl_check = allocated(self%pl_discards) ltp_check = allocated(self%tp_discards) - associate(nbody_system => self, tp => self%tp, pl => self%pl, tp_discards => self%tp_discards, pl_discards => self%pl_discards, nc => self%system_history%nc) + associate(nbody_system => self, tp => self%tp, pl => self%pl, tp_discards => self%tp_discards, pl_discards => self%pl_discards) lpl_discards = .false. ltp_discards = .false. if (lpl_check .and. pl%nbody > 0) then @@ -131,7 +131,7 @@ subroutine swiftest_discard_cb_tp(tp, nbody_system, param) ! Internals integer(I4B) :: i real(DP) :: energy, vb2, rb2, rh2, rmin2, rmax2, rmaxu2 - character(len=STRMAX) :: idstr, timestr + character(len=STRMAX) :: idstr, timestr, message associate(ntp => tp%nbody, cb => nbody_system%cb, Gmtot => nbody_system%Gmtot) rmin2 = max(param%rmin * param%rmin, cb%radius * cb%radius) @@ -144,8 +144,9 @@ subroutine swiftest_discard_cb_tp(tp, nbody_system, param) tp%status(i) = DISCARDED_RMAX write(idstr, *) tp%id(i) write(timestr, *) nbody_system%t - write(*, *) "Particle " // trim(adjustl(tp%info(i)%name)) // " (" // trim(adjustl(idstr)) // ")" // & + write(message, *) "Particle " // trim(adjustl(tp%info(i)%name)) // " (" // trim(adjustl(idstr)) // ")" // & " too far from the central body at t = " // trim(adjustl(timestr)) + call swiftest_io_log_one_message(COLLISION_LOG_OUT, message) tp%ldiscard(i) = .true. tp%lmask(i) = .false. call tp%info(i)%set_value(status="DISCARDED_RMAX", discard_time=nbody_system%t, discard_rh=tp%rh(:,i), & @@ -154,8 +155,9 @@ subroutine swiftest_discard_cb_tp(tp, nbody_system, param) tp%status(i) = DISCARDED_RMIN write(idstr, *) tp%id(i) write(timestr, *) nbody_system%t - write(*, *) "Particle " // trim(adjustl(tp%info(i)%name)) // " (" // trim(adjustl(idstr)) // ")" // & + write(message, *) "Particle " // trim(adjustl(tp%info(i)%name)) // " (" // trim(adjustl(idstr)) // ")" // & " too close to the central body at t = " // trim(adjustl(timestr)) + call swiftest_io_log_one_message(COLLISION_LOG_OUT, message) tp%ldiscard(i) = .true. tp%lmask(i) = .false. call tp%info(i)%set_value(status="DISCARDED_RMIN", discard_time=nbody_system%t, discard_rh=tp%rh(:,i), & @@ -168,8 +170,9 @@ subroutine swiftest_discard_cb_tp(tp, nbody_system, param) tp%status(i) = DISCARDED_RMAXU write(idstr, *) tp%id(i) write(timestr, *) nbody_system%t - write(*, *) "Particle " // trim(adjustl(tp%info(i)%name)) // " (" // trim(adjustl(idstr)) // ")" // & + write(message, *) "Particle " // trim(adjustl(tp%info(i)%name)) // " (" // trim(adjustl(idstr)) // ")" // & " is unbound and too far from barycenter at t = " // trim(adjustl(timestr)) + call swiftest_io_log_one_message(COLLISION_LOG_OUT, message) tp%ldiscard(i) = .true. tp%lmask(i) = .false. call tp%info(i)%set_value(status="DISCARDED_RMAXU", discard_time=nbody_system%t, discard_rh=tp%rh(:,i), & @@ -254,7 +257,7 @@ subroutine swiftest_discard_pl_tp(tp, nbody_system, param) integer(I4B) :: i, j, isp real(DP) :: r2min, radius real(DP), dimension(NDIM) :: dx, dv - character(len=STRMAX) :: idstri, idstrj, timestr + character(len=STRMAX) :: idstri, idstrj, timestr, message associate(ntp => tp%nbody, pl => nbody_system%pl, npl => nbody_system%pl%nbody, t => nbody_system%t, dt => param%dt) do i = 1, ntp @@ -271,9 +274,10 @@ subroutine swiftest_discard_pl_tp(tp, nbody_system, param) write(idstri, *) tp%id(i) write(idstrj, *) pl%id(j) write(timestr, *) nbody_system%t - write(*, *) "Test particle " // trim(adjustl(tp%info(i)%name)) // " (" // trim(adjustl(idstri)) // ")" & + write(message, *) "Test particle " // trim(adjustl(tp%info(i)%name)) // " (" // trim(adjustl(idstri)) // ")" & // " too close to massive body " // trim(adjustl(pl%info(j)%name)) // " (" // trim(adjustl(idstrj)) // ")" & // " at t = " // trim(adjustl(timestr)) + call swiftest_io_log_one_message(COLLISION_LOG_OUT, message) tp%ldiscard(i) = .true. call tp%info(i)%set_value(status="DISCARDED_PLR", discard_time=nbody_system%t, discard_rh=tp%rh(:,i), & discard_vh=tp%vh(:,i), discard_body_id=pl%id(j)) diff --git a/src/swiftest/swiftest_drift.f90 b/src/swiftest/swiftest_drift.f90 index b7811f88c..4c7302908 100644 --- a/src/swiftest/swiftest_drift.f90 +++ b/src/swiftest/swiftest_drift.f90 @@ -1,10 +1,10 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh +!! Coryright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh !! This file is part of Swiftest. !! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License !! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. !! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty !! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. +!! You should have received a cory of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. submodule (swiftest) s_swiftest_drift @@ -104,7 +104,7 @@ module subroutine swiftest_drift_all(mu, x, v, n, param, dt, lmask, iflag) end subroutine swiftest_drift_all - pure elemental module subroutine swiftest_drift_one(mu, px, py, pz, vx, vy, vz, dt, iflag) + pure elemental module subroutine swiftest_drift_one(mu, rx, ry, rz, vx, vy, vz, dt, iflag) !! author: The Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott !! !! Perform Danby drift for one body, redoing drift with smaller substeps if original accuracy is insufficient @@ -114,18 +114,18 @@ pure elemental module subroutine swiftest_drift_one(mu, px, py, pz, vx, vy, vz, implicit none ! Arguments real(DP), intent(in) :: mu !! G * (Mcb + m), G = gravitational constant, Mcb = mass of central body, m = mass of body to drift - real(DP), intent(inout) :: px, py, pz, vx, vy, vz !! Position and velocity of body to drift + real(DP), intent(inout) :: rx, ry, rz, vx, vy, vz !! Position and velocity of body to drift real(DP), intent(in) :: dt !! Step size integer(I4B), intent(out) :: iflag !! iflag : error status flag for Danby drift (0 = OK, nonzero = ERROR) ! Internals integer(I4B) :: i real(DP) :: dttmp - call swiftest_drift_dan(mu, px, py, pz, vx, vy, vz, dt, iflag) + call swiftest_drift_dan(mu, rx, ry, rz, vx, vy, vz, dt, iflag) if (iflag /= 0) then dttmp = 0.1_DP * dt do i = 1, 10 - call swiftest_drift_dan(mu, px, py, pz, vx, vy, vz, dttmp, iflag) + call swiftest_drift_dan(mu, rx, ry, rz, vx, vy, vz, dttmp, iflag) if (iflag /= 0) exit end do end if @@ -134,7 +134,7 @@ pure elemental module subroutine swiftest_drift_one(mu, px, py, pz, vx, vy, vz, end subroutine swiftest_drift_one - pure subroutine swiftest_drift_dan(mu, px0, py0, pz0, vx0, vy0, vz0, dt0, iflag) + pure subroutine swiftest_drift_dan(mu, rx0, ry0, rz0, vx0, vy0, vz0, dt0, iflag) !! author: David A. Minton !! !! Perform Kepler drift, solving Kepler's equation in appropriate variables @@ -144,23 +144,21 @@ pure subroutine swiftest_drift_dan(mu, px0, py0, pz0, vx0, vy0, vz0, dt0, iflag) implicit none ! Arguments real(DP), intent(in) :: mu !! G * (m1 + m2), G = gravitational constant, m1 = mass of central body, m2 = mass of body to drift - real(DP), intent(inout) :: px0, py0, pz0 !! position of body to drift + real(DP), intent(inout) :: rx0, ry0, rz0 !! position of body to drift real(DP), intent(inout) :: vx0, vy0, vz0 !! velocity of body to drift real(DP), intent(in) :: dt0 !! time step integer(I4B), intent(out) :: iflag !! error status flag for Kepler drift (0 = OK, nonzero = NO CONVERGENCE) ! Internals - real(DP) :: dt, f, g, fdot, gdot, c1, c2, c3, u, alpha, fp, r0 + real(DP) :: rx, ry, rz, vx, vy, vz, dt + real(DP) :: f, g, fdot, gdot, c1, c2, c3, u, alpha, fp, r0 real(DP) :: v0s, a, asq, en, dm, ec, es, esq, xkep, fchk, s, c - real(DP), dimension(NDIM) :: x, v, x0, v0 ! Executable code iflag = 0 dt = dt0 - x0 = [px0, py0, pz0] - v0 = [vx0, vy0, vz0] - r0 = sqrt(dot_product(x0(:), x0(:))) - v0s = dot_product(v0(:), v0(:)) - u = dot_product(x0(:), v0(:)) + r0 = sqrt(rx0*rx0 + ry0*ry0 + rz0*rz0) + v0s = vx0*vx0 + vy0*vy0 + vz0*vz0 + u = rx0*vx0 + ry0*vy0 + rz0*vz0 alpha = 2 * mu / r0 - v0s if (alpha > 0.0_DP) then a = mu / alpha @@ -186,10 +184,19 @@ pure subroutine swiftest_drift_dan(mu, px0, py0, pz0, vx0, vy0, vz0, dt0, iflag) g = dt + (s - xkep) / en fdot = -(a / (r0 * fp)) * en * s gdot = (c - 1.0_DP) / fp + 1.0_DP - x(:) = x0(:) * f + v0(:) * g - v(:) = x0(:) * fdot + v0(:) * gdot - px0 = x(1); py0 = x(2); pz0 = x(3) - vx0 = v(1); vy0 = v(2); vz0 = v(3) + rx = rx0 * f + vx0 * g + ry = ry0 * f + vy0 * g + rz = rz0 * f + vz0 * g + vx = rx0 * fdot + vx0 * gdot + vy = ry0 * fdot + vy0 * gdot + vz = rz0 * fdot + vz0 * gdot + + rx0 = rx + ry0 = ry + rz0 = rz + vx0 = vx + vy0 = vy + vz0 = vz iflag = 0 return end if @@ -201,10 +208,19 @@ pure subroutine swiftest_drift_dan(mu, px0, py0, pz0, vx0, vy0, vz0, dt0, iflag) g = dt - mu * c3 fdot = -mu / (fp * r0) * c1 gdot = 1.0_DP - mu / fp * c2 - x(:) = x0(:) * f + v0(:) * g - v(:) = x0(:) * fdot + v0(:) * gdot - px0 = x(1); py0 = x(2); pz0 = x(3) - vx0 = v(1); vy0 = v(2); vz0 = v(3) + rx = rx0 * f + vx0 * g + ry = ry0 * f + vy0 * g + rz = rz0 * f + vz0 * g + vx = rx0 * fdot + vx0 * gdot + vy = ry0 * fdot + vy0 * gdot + vz = rz0 * fdot + vz0 * gdot + + rx0 = rx + ry0 = ry + rz0 = rz + vx0 = vx + vy0 = vy + vz0 = vz end if return diff --git a/src/swiftest/swiftest_driver.f90 b/src/swiftest/swiftest_driver.f90 index bfa950222..d8e2ae219 100644 --- a/src/swiftest/swiftest_driver.f90 +++ b/src/swiftest/swiftest_driver.f90 @@ -20,30 +20,31 @@ program swiftest_driver implicit none class(swiftest_nbody_system), allocatable :: nbody_system !! Polymorphic object containing the nbody system to be integrated - class(swiftest_parameters), allocatable :: param !! Run configuration parameters + type(swiftest_parameters) :: param !! Run configuration parameters + class(swiftest_storage), allocatable :: system_history !! Stores the system history between output dumps character(len=:), allocatable :: integrator !! Integrator type code (see globals for symbolic names) character(len=:), allocatable :: param_file_name !! Name of the file containing user-defined parameters character(len=:), allocatable :: display_style !! Style of the output display {"STANDARD", "COMPACT", "PROGRESS"}). Default is "STANDARD" - integer(I8B) :: istart !! Starting index for loop counter - integer(I4B) :: iout !! Output cadence counter - integer(I4B) :: idump !! Dump cadence counter - integer(I4B) :: nout !! Current output step - integer(I4B) :: istep !! Current value of istep (used for time stretching) type(walltimer) :: integration_timer !! Object used for computing elapsed wall time call swiftest_io_get_args(integrator, param_file_name, display_style) !> Read in the user-defined parameters file and the initial conditions of the nbody_system - allocate(swiftest_parameters :: param) param%integrator = trim(adjustl(integrator)) param%display_style = trim(adjustl(display_style)) call param%read_in(param_file_name) + if (.not.param%lcoarray .and. (this_image() /= 1)) stop ! Single image mode associate(t0 => param%t0, & tstart => param%tstart, & dt => param%dt, & tstop => param%tstop, & iloop => param%iloop, & + istart => param%istart, & + iout => param%iout, & + idump => param%idump, & + nout => param%nout, & + istep => param%istep, & nloops => param%nloops, & istep_out => param%istep_out, & fstep_out => param%fstep_out, & @@ -74,72 +75,115 @@ program swiftest_driver !> Define the maximum number of threads nthreads = 1 ! In the *serial* case !$ nthreads = omp_get_max_threads() ! In the *parallel* case - !$ write(param%display_unit,'(a)') ' OpenMP parameters:' - !$ write(param%display_unit,'(a)') ' ------------------' - !$ write(param%display_unit,'(a,i3,/)') ' Number of threads = ', nthreads - !$ if (param%log_output) write(*,'(a,i3)') ' OpenMP: Number of threads = ',nthreads - - call nbody_system%initialize(param) - - associate (system_history => nbody_system%system_history) - ! If this is a new run, compute energy initial conditions (if energy tracking is turned on) and write the initial conditions to file. - call nbody_system%display_run_information(param, integration_timer, phase="first") - if (param%lenergy) then - if (param%lrestart) then - call nbody_system%get_t0_values(param) - else - call nbody_system%conservation_report(param, lterminal=.false.) ! This will save the initial values of energy and momentum - end if - call nbody_system%conservation_report(param, lterminal=.true.) +#ifdef COARRAY + if (this_image() == 1 .or. param%log_output) then +#endif + !$ write(param%display_unit,'(a)') ' OpenMP parameters:' + !$ write(param%display_unit,'(a)') ' ------------------' + !$ write(param%display_unit,'(a,i3,/)') ' Number of threads = ', nthreads + !$ if (param%log_output) write(*,'(a,i3)') ' OpenMP: Number of threads = ',nthreads +#ifdef COARRAY + if (param%lcoarray) then + write(param%display_unit,*) ' Coarray parameters:' + write(param%display_unit,*) ' -------------------' + write(param%display_unit,*) ' Number of images = ', num_images() + if (param%log_output .and. this_image() == 1) write(*,'(a,i3)') ' Coarray: Number of images = ',num_images() + else + write(param%display_unit,*) ' Coarrays disabled.' + if (param%log_output) write(*,*) ' Coarrays disabled.' + end if + end if +#endif + if (param%log_output) flush(param%display_unit) + +#ifdef COARRAY + ! The following line lets us read in the input files one image at a time. Letting each image read the input in is faster than broadcasting all of the data + if (param%lcoarray .and. (this_image() /= 1)) sync images(this_image() - 1) +#endif + call nbody_system%initialize(system_history, param) +#ifdef COARRAY + if (param%lcoarray .and. (this_image() < num_images())) sync images(this_image() + 1) + + ! Distribute test particles to the various images + if (param%lcoarray) call nbody_system%coarray_distribute(param) +#endif + + ! If this is a new run, compute energy initial conditions (if energy tracking is turned on) and write the initial conditions to file. + call nbody_system%display_run_information(param, integration_timer, phase="first") + + if (param%lenergy) then + if (param%lrestart) then + call nbody_system%get_t0_values(system_history%nc, param) + else + call nbody_system%conservation_report(param, lterminal=.false.) ! This will save the initial values of energy and momentum end if - call system_history%take_snapshot(param,nbody_system) - call nbody_system%dump(param) - - do iloop = istart, nloops - !> Step the nbody_system forward in time - call integration_timer%start() - call nbody_system%step(param, nbody_system%t, dt) - call integration_timer%stop() - - nbody_system%t = t0 + iloop * dt - - !> Evaluate any discards or collisional outcomes - call nbody_system%discard(param) - - !> If the loop counter is at the output cadence value, append the data file with a single frame - if (istep_out > 0) then - iout = iout + 1 - if ((iout == istep) .or. (iloop == nloops)) then - iout = 0 - idump = idump + 1 - if (ltstretch) then - nout = nout + 1 - istep = floor(istep_out * fstep_out**nout, kind=I4B) - end if - - call system_history%take_snapshot(param,nbody_system) - - if (idump == dump_cadence) then - idump = 0 - call nbody_system%dump(param) - end if + call nbody_system%conservation_report(param, lterminal=.true.) + end if - call integration_timer%report(message="Integration steps:", unit=display_unit) - call nbody_system%display_run_information(param, integration_timer) - call integration_timer%reset() - if (param%lenergy) call nbody_system%conservation_report(param, lterminal=.true.) + call system_history%take_snapshot(param,nbody_system) + call nbody_system%dump(param, system_history) + + do iloop = istart, nloops + !> Step the nbody_system forward in time + call integration_timer%start() + call nbody_system%step(param, nbody_system%t, dt) + call integration_timer%stop() + + nbody_system%t = t0 + iloop * dt + + !> Evaluate any discards or collisional outcomes + call nbody_system%discard(param) + + !> If the loop counter is at the output cadence value, append the data file with a single frame + if (istep_out > 0) then + iout = iout + 1 + if ((iout == istep) .or. (iloop == nloops)) then + iout = 0 + idump = idump + 1 + if (ltstretch) then + nout = nout + 1 + istep = floor(istep_out * fstep_out**nout, kind=I4B) + end if + + call system_history%take_snapshot(param,nbody_system) + if (idump == dump_cadence) then + idump = 0 + call nbody_system%dump(param, system_history) +#ifdef COARRAY + if (param%lcoarray) call nbody_system%coarray_balance(param) +#endif end if +#ifdef COARRAY + if (this_image() == 1 .or. param%log_output) then +#endif + call integration_timer%report(message="Integration steps:", unit=display_unit) +#ifdef COARRAY + end if !(this_image() == 1) +#endif + call nbody_system%display_run_information(param, integration_timer) + call integration_timer%reset() +#ifdef COARRAY + if (this_image() == 1 .or. param%log_output) then +#endif + if (param%lenergy) call nbody_system%conservation_report(param, lterminal=.true.) +#ifdef COARRAY + end if ! (this_image() == 1) +#endif end if + end if - end do - ! Dump any remaining history if it exists - call nbody_system%dump(param) - call system_history%dump(param) - call nbody_system%display_run_information(param, integration_timer, phase="last") - - end associate + end do + ! Dump any remaining history if it exists + call nbody_system%dump(param, system_history) + call nbody_system%display_run_information(param, integration_timer, phase="last") end associate - call base_util_exit(SUCCESS) +#ifdef COARRAY + if (this_image() == 1) then +#endif + call base_util_exit(SUCCESS) +#ifdef COARRAY + end if ! (this_image() == 1) +#endif end program swiftest_driver diff --git a/src/swiftest/swiftest_io.f90 b/src/swiftest/swiftest_io.f90 index 32f722a7b..ba0559721 100644 --- a/src/swiftest/swiftest_io.f90 +++ b/src/swiftest/swiftest_io.f90 @@ -127,7 +127,7 @@ module subroutine swiftest_io_conservation_report(self, param, lterminal) integer(I4B), parameter :: EGYIU = 72 character(len=*), parameter :: EGYTERMFMT = '(" DL/L0 = ", ES12.5, "; DE_orbit/|E0| = ", ES12.5, "; DE_total/|E0| = ", ES12.5, "; DM/M0 = ", ES12.5)' - associate(nbody_system => self, pl => self%pl, cb => self%cb, npl => self%pl%nbody, display_unit => param%display_unit, nc => self%system_history%nc) + associate(nbody_system => self, pl => self%pl, cb => self%cb, npl => self%pl%nbody, display_unit => param%display_unit) select type(self) class is (helio_nbody_system) ! Don't convert vh to vb for Helio-based integrators, because they are already have that calculated @@ -183,14 +183,21 @@ module subroutine swiftest_io_conservation_report(self, param, lterminal) nbody_system%L_total_error = norm2(L_total_now(:) - nbody_system%L_total_orig(:)) / norm2(nbody_system%L_total_orig(:)) nbody_system%Mescape_error = nbody_system%GMescape / nbody_system%GMtot_orig +#ifdef COARRAY + if (this_image() == 1 .or. param%log_output) then +#endif + if (lterminal) then + write(display_unit, EGYTERMFMT) nbody_system%L_total_error, nbody_system%E_orbit_error, nbody_system%te_error,nbody_system%Mtot_error + if (param%log_output) flush(display_unit) + end if - if (lterminal) write(display_unit, EGYTERMFMT) nbody_system%L_total_error, nbody_system%E_orbit_error, nbody_system%te_error,nbody_system%Mtot_error +#ifdef COARRAY + end if ! (this_image() == 1) then +#endif if (abs(nbody_system%Mtot_error) > 100 * epsilon(nbody_system%Mtot_error)) then write(*,*) "Severe error! Mass not conserved! Halting!" ! Save the frame of data to the bin file in the slot just after the present one for diagnostics - call self%write_frame(nc, param) - call nc%close() call base_util_exit(FAILURE) end if end if @@ -220,12 +227,21 @@ module subroutine swiftest_io_display_run_information(self, param, integration_t type(progress_bar), save :: pbar !! Object used to print out a progress bar character(len=64) :: pbarmessage character(*), parameter :: symbacompactfmt = '(";NPLM",ES22.15,$)' +#ifdef COARRAY + character(*), parameter :: co_statusfmt = '("Image: ",I4, "; Time = ", ES12.5, "; fraction done = ", F6.3, ' // & + '"; Number of active pl, tp = ", I6, ", ", I6)' + character(*), parameter :: co_symbastatfmt = '("Image: ",I4, "; Image: Time = ", ES12.5, "; fraction done = ", F6.3, ' // & + '"; Number of active pl, plm, tp = ", I6, ", ", I6, ", ", I6)' +#endif character(*), parameter :: statusfmt = '("Time = ", ES12.5, "; fraction done = ", F6.3, ' // & '"; Number of active pl, tp = ", I6, ", ", I6)' character(*), parameter :: symbastatfmt = '("Time = ", ES12.5, "; fraction done = ", F6.3, ' // & '"; Number of active pl, plm, tp = ", I6, ", ", I6, ", ", I6)' character(*), parameter :: pbarfmt = '("Time = ", ES12.5," of ",ES12.5)' +! The following will syncronize the images so that they report in order, and only write to file one at at ime + + phase_val = 1 if (present(phase)) then if (phase == "first") then @@ -237,36 +253,72 @@ module subroutine swiftest_io_display_run_information(self, param, integration_t tfrac = (self%t - param%t0) / (param%tstop - param%t0) - if (phase_val == 0) then - if (param%lrestart) then - write(param%display_unit, *) " *************** Swiftest restart " // param%integrator // " *************** " - else - write(param%display_unit, *) " *************** Swiftest start " // param%integrator // " *************** " - end if - if (param%display_style == "PROGRESS") then - call pbar%reset(param%nloops) - else if (param%display_style == "COMPACT") then - write(*,*) "SWIFTEST START " // param%integrator +#ifdef COARRAY + if (this_image() == 1 .or. param%log_output) then +#endif + if (phase_val == 0) then + if (param%lrestart) then + write(param%display_unit, *) " *************** Swiftest restart " // trim(adjustl(param%integrator)) // " *************** " + else + write(param%display_unit, *) " *************** Swiftest start " // trim(adjustl(param%integrator)) // " *************** " + end if + if (param%display_style == "PROGRESS") then + call pbar%reset(param%nloops) + else if (param%display_style == "COMPACT") then + write(param%display_unit,*) "SWIFTEST START " // trim(adjustl(param%integrator)) + end if end if - end if +#ifdef COARRAY + end if !(this_image() == 1) +#endif if (param%display_style == "PROGRESS") then - write(pbarmessage,fmt=pbarfmt) self%t, param%tstop - call pbar%update(1_I8B,message=pbarmessage) +#ifdef COARRAY + if (this_image() == 1) then +#endif + write(pbarmessage,fmt=pbarfmt) self%t, param%tstop + call pbar%update(1_I8B,message=pbarmessage) +#ifdef COARRAY + end if !(this_image() == 1) +#endif else if (param%display_style == "COMPACT") then call self%compact_output(param,integration_timer) end if if (self%pl%nplm > 0) then - write(param%display_unit, symbastatfmt) self%t, tfrac, self%pl%nbody, self%pl%nplm, self%tp%nbody +#ifdef COARRAY + if (param%lcoarray) then + write(param%display_unit, co_symbastatfmt) this_image(),self%t, tfrac, self%pl%nbody, self%pl%nplm, self%tp%nbody + else +#endif + write(param%display_unit, symbastatfmt) self%t, tfrac, self%pl%nbody, self%pl%nplm, self%tp%nbody +#ifdef COARRAY + end if +#endif else - write(param%display_unit, statusfmt) self%t, tfrac, self%pl%nbody, self%tp%nbody +#ifdef COARRAY + if (param%lcoarray) then + write(param%display_unit, co_statusfmt) this_image(),self%t, tfrac, self%pl%nbody, self%tp%nbody + else +#endif + write(param%display_unit, statusfmt) self%t, tfrac, self%pl%nbody, self%tp%nbody +#ifdef COARRAY + end if +#endif end if - if (phase_val == -1) then - write(param%display_unit, *)" *************** Swiftest stop " // param%integrator // " *************** " - if (param%display_style == "COMPACT") write(*,*) "SWIFTEST STOP" // param%integrator - end if +#ifdef COARRAY + if (this_image() == num_images() .or. param%log_output) then +#endif + if (phase_val == -1) then + write(param%display_unit, *)" *************** Swiftest stop " // trim(adjustl(param%integrator)) // " *************** " + if (param%display_style == "COMPACT") write(*,*) "SWIFTEST STOP" // trim(adjustl(param%integrator)) + end if + +#ifdef COARRAY + end if ! this_image() == num_images() + if (param%log_output) flush(param%display_unit) +#endif return end subroutine swiftest_io_display_run_information @@ -303,7 +355,7 @@ module subroutine swiftest_io_dump_param(self, param_file_name) end subroutine swiftest_io_dump_param - module subroutine swiftest_io_dump_system(self, param) + module subroutine swiftest_io_dump_system(self, param, system_history) !! author: David A. Minton !! !! Dumps the state of the nbody_system to files in case the simulation is interrupted. @@ -313,6 +365,7 @@ module subroutine swiftest_io_dump_system(self, param) ! Arguments class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody_system object class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(swiftest_storage), intent(inout) :: system_history !! Stores the system history between output dumps ! Internals class(swiftest_parameters), allocatable :: param_restart !! Local parameters variable used to parameters change input file names !! to dump file-specific values without changing the user-defined values @@ -324,21 +377,26 @@ module subroutine swiftest_io_dump_system(self, param) if (allocated(self%collision_history)) call self%collision_history%dump(param) ! Dump the nbody_system history to file - call self%system_history%dump(param) - - allocate(param_restart, source=param) - param_restart%in_form = "XV" - param_restart%out_stat = 'APPEND' - param_restart%in_type = "NETCDF_DOUBLE" - param_restart%nc_in = param%outfile - param_restart%lrestart = .true. - param_restart%tstart = self%t - param_file_name = trim(adjustl(PARAM_RESTART_FILE)) - call param_restart%dump(param_file_name) - write(time_text,'(I0.20)') param%iloop - param_file_name = "param." // trim(adjustl(time_text)) // ".in" - call param_restart%dump(param_file_name) - + call system_history%dump(param) + +#ifdef COARRAY + if (this_image() == 1) then +#endif + allocate(param_restart, source=param) + param_restart%in_form = "XV" + param_restart%out_stat = 'APPEND' + param_restart%in_type = "NETCDF_DOUBLE" + param_restart%nc_in = param%outfile + param_restart%lrestart = .true. + param_restart%tstart = self%t + param_file_name = trim(adjustl(PARAM_RESTART_FILE)) + call param_restart%dump(param_file_name) + write(time_text,'(I0.20)') param%iloop + param_file_name = "param." // trim(adjustl(time_text)) // ".in" + call param_restart%dump(param_file_name) +#ifdef COARRAY + end if ! (this_image() == 1) +#endif return end subroutine swiftest_io_dump_system @@ -353,26 +411,48 @@ module subroutine swiftest_io_dump_storage(self, param) implicit none ! Arguments class(swiftest_storage), intent(inout) :: self !! Swiftest simulation history storage object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters ! Internals integer(I4B) :: i if (self%iframe == 0) return call self%make_index_map() associate(nc => self%nc) +#ifdef COARRAY + critical +#endif call nc%open(param) - +#ifdef COARRAY + end critical +#endif do i = 1, self%iframe + ! Writing files is more efficient if we write out the common frames from each image before going to the next frame +#ifdef COARRAY + if (param%lcoarray .and. (this_image() /= 1)) sync images(this_image() - 1) +#endif if (allocated(self%frame(i)%item)) then select type(nbody_system => self%frame(i)%item) class is (swiftest_nbody_system) - call nbody_system%write_frame(param) + call nbody_system%write_frame(nc, param) end select deallocate(self%frame(i)%item) end if +#ifdef COARRAY + if (param%lcoarray .and. (this_image() < num_images())) sync images(this_image() + 1) + sync all +#endif end do - call nc%close() +#ifdef COARRAY + if (this_image() == 1) then +#endif + call nc%close() +#ifdef COARRAY + else + nc%lfile_is_open = .false. + end if +#endif end associate + call self%reset() return end subroutine swiftest_io_dump_storage @@ -566,15 +646,16 @@ module subroutine swiftest_io_netcdf_flush(self, param) end subroutine swiftest_io_netcdf_flush - module subroutine swiftest_io_netcdf_get_t0_values_system(self, param) + module subroutine swiftest_io_netcdf_get_t0_values_system(self, nc, param) !! author: David A. Minton !! !! Gets the t0 values of various parameters such as energy and momentum !! implicit none ! Arguments - class(swiftest_nbody_system), intent(inout) :: self - class(swiftest_parameters), intent(inout) :: param + class(swiftest_nbody_system), intent(inout) :: self + class(swiftest_netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular NetCDF dataset + class(swiftest_parameters), intent(inout) :: param ! Internals integer(I4B) :: itmax, idmax, tslot real(DP), dimension(:), allocatable :: vals @@ -582,7 +663,7 @@ module subroutine swiftest_io_netcdf_get_t0_values_system(self, param) real(DP), dimension(NDIM) :: rot0, Ip0, L real(DP) :: mass0 - associate (nc => self%system_history%nc, cb => self%cb) + associate (cb => self%cb) call nc%open(param, readonly=.true.) call nc%find_tslot(param%t0, tslot) call netcdf_io_check( nf90_inquire_dimension(nc%id, nc%time_dimid, len=itmax), "netcdf_io_get_t0_values_system time_dimid" ) @@ -849,7 +930,6 @@ module subroutine swiftest_io_netcdf_open(self, param, readonly) end if associate(nc => self) - write(errmsg,*) "swiftest_io_netcdf_open nf90_open ",trim(adjustl(nc%file_name)) call netcdf_io_check( nf90_open(nc%file_name, mode, nc%id), errmsg) self%lfile_is_open = .true. @@ -972,7 +1052,7 @@ module subroutine swiftest_io_netcdf_get_valid_masks(self, plmask, tpmask) real(DP), dimension(:,:), allocatable :: rh integer(I4B), dimension(:), allocatable :: body_status logical, dimension(:), allocatable :: lvalid - integer(I4B) :: idmax, status + integer(I4B) :: idmax, status,i call netcdf_io_check( nf90_inquire_dimension(self%id, self%name_dimid, len=idmax), "swiftest_io_netcdf_get_valid_masks nf90_inquire_dimension name_dimid" ) @@ -980,7 +1060,6 @@ module subroutine swiftest_io_netcdf_get_valid_masks(self, plmask, tpmask) allocate(tpmask(idmax)) allocate(plmask(idmax)) allocate(lvalid(idmax)) - associate(tslot => self%tslot) call netcdf_io_check( nf90_get_var(self%id, self%Gmass_varid, Gmass, start=[1,tslot], count=[idmax,1]), "swiftest_io_netcdf_get_valid_masks nf90_getvar Gmass_varid" ) @@ -1008,7 +1087,8 @@ module subroutine swiftest_io_netcdf_get_valid_masks(self, plmask, tpmask) end if end if - plmask(:) = Gmass(:) == Gmass(:) + plmask(:) = (Gmass(:) == Gmass(:)) + where(plmask(:)) plmask(:) = Gmass(:) > 0.0_DP tpmask(:) = .not. plmask(:) plmask(1) = .false. ! This is the central body @@ -1068,10 +1148,14 @@ module function swiftest_io_netcdf_read_frame_system(self, nc, param) result(ier if (npl_check /= npl) then write(*,*) "Error reading in NetCDF file: The recorded value of npl does not match the number of active massive bodies" + write(*,*) "Recorded: ",npl + write(*,*) "Active : ",npl_check end if if (ntp_check /= ntp) then write(*,*) "Error reading in NetCDF file: The recorded value of ntp does not match the number of active test particles" + write(*,*) "Recorded: ",ntp + write(*,*) "Active : ",ntp_check call base_util_exit(failure) end if @@ -1541,10 +1625,11 @@ module subroutine swiftest_io_netcdf_write_frame_body(self, nc, param) class(swiftest_netcdf_parameters), intent(inout) :: nc !! Parameters used to for writing a NetCDF dataset to file class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters ! Internals - integer(I4B) :: i, j, idslot, old_mode + integer(I4B) :: i, j, idslot, old_mode, ntp integer(I4B), dimension(:), allocatable :: ind real(DP), dimension(NDIM) :: vh !! Temporary variable to store heliocentric velocity values when converting from pseudovelocity in GR-enabled runs real(DP) :: a, e, inc, omega, capom, capm, varpi, lam, f, cape, capf + logical, dimension(:), allocatable :: tpmask, plmask call self%write_info(nc, param) @@ -1556,7 +1641,7 @@ module subroutine swiftest_io_netcdf_write_frame_body(self, nc, param) associate(n => self%nbody, tslot => nc%tslot) if (n == 0) return - call swiftest_util_sort(self%id(1:n), ind) + call util_sort(self%id(1:n), ind) do i = 1, n j = ind(i) @@ -1617,12 +1702,31 @@ module subroutine swiftest_io_netcdf_write_frame_body(self, nc, param) ! call netcdf_io_check( nf90_put_var(nc%id, nc%k2_varid, self%k2(j), start=[idslot, tslot]), "netcdf_io_write_frame_body nf90_put_var body k2_varid" ) ! call netcdf_io_check( nf90_put_var(nc%id, nc%Q_varid, self%Q(j), start=[idslot, tslot]), "netcdf_io_write_frame_body nf90_put_var body Q_varid" ) ! end if - + class is (swiftest_tp) + call netcdf_io_check( nf90_put_var(nc%id, nc%Gmass_varid, 0.0_DP, start=[idslot, tslot]), "netcdf_io_write_frame_body nf90_put_var body Gmass_varid" ) + call netcdf_io_check( nf90_put_var(nc%id, nc%mass_varid, 0.0_DP, start=[idslot, tslot]), "netcdf_io_write_frame_body nf90_put_var body mass_varid" ) + if (param%lrhill_present) then + call netcdf_io_check( nf90_put_var(nc%id, nc%rhill_varid, 0.0_DP, start=[idslot, tslot]), "netcdf_io_write_frame_body nf90_put_var body rhill_varid" ) + end if + if (param%lclose) call netcdf_io_check( nf90_put_var(nc%id, nc%radius_varid, 0.0_DP, start=[idslot, tslot]), "netcdf_io_write_frame_body nf90_put_var body radius_varid" ) + if (param%lrotation) then + call netcdf_io_check( nf90_put_var(nc%id, nc%Ip_varid, [0.0_DP,0.0_DP,0.0_DP], start=[1,idslot, tslot], count=[NDIM,1,1]), "netcdf_io_write_frame_body nf90_put_var body Ip_varid" ) + call netcdf_io_check( nf90_put_var(nc%id, nc%rot_varid, [0.0_DP,0.0_DP,0.0_DP], start=[1,idslot, tslot], count=[NDIM,1,1]), "netcdf_io_write_frame_body nf90_put_var body rotx_varid" ) + end if end select end do end associate end select end select +#ifdef COARRAY + select type(self) + class is (swiftest_tp) + call nc%get_valid_masks(plmask, tpmask) + ntp = count(tpmask(:)) + call netcdf_io_check( nf90_put_var(nc%id, nc%ntp_varid, ntp, start=[nc%tslot]), "netcdf_io_write_frame_body nf90_put_var ntp_varid" ) + end select +#endif + call netcdf_io_check( nf90_set_fill(nc%id, old_mode, old_mode), "netcdf_io_write_frame_body nf90_set_fill old_mode" ) return @@ -1678,8 +1782,14 @@ module subroutine swiftest_io_netcdf_write_frame_system(self, nc, param) class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters call self%write_hdr(nc, param) - call self%cb%write_frame(nc, param) - call self%pl%write_frame(nc, param) +#ifdef COARRAY + if (this_image() == 1) then +#endif + call self%cb%write_frame(nc, param) + call self%pl%write_frame(nc, param) +#ifdef COARRAY + end if ! this_image() == 1 +#endif call self%tp%write_frame(nc, param) return @@ -1698,13 +1808,15 @@ module subroutine swiftest_io_netcdf_write_hdr_system(self, nc, param) class(swiftest_netcdf_parameters), intent(inout) :: nc !! Parameters used to for writing a NetCDF dataset to file class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters ! Internals - integer(I4B) :: i,tslot, idmax - integer(I4B), dimension(:), allocatable :: body_status + logical, dimension(:), allocatable :: tpmask, plmask + integer(I4B) :: tslot call nc%find_tslot(self%t, tslot) call netcdf_io_check( nf90_put_var(nc%id, nc%time_varid, self%t, start=[tslot]), "netcdf_io_write_hdr_system nf90_put_var time_varid" ) call netcdf_io_check( nf90_put_var(nc%id, nc%npl_varid, self%pl%nbody, start=[tslot]), "netcdf_io_write_hdr_system nf90_put_var npl_varid" ) +#ifndef COARRAY call netcdf_io_check( nf90_put_var(nc%id, nc%ntp_varid, self%tp%nbody, start=[tslot]), "netcdf_io_write_hdr_system nf90_put_var ntp_varid" ) +#endif if (param%lmtiny_pl) call netcdf_io_check( nf90_put_var(nc%id, nc%nplm_varid, self%pl%nplm, start=[tslot]), "netcdf_io_write_hdr_system nf90_put_var nplm_varid" ) if (param%lenergy) then @@ -1721,10 +1833,6 @@ module subroutine swiftest_io_netcdf_write_hdr_system(self, nc, param) call netcdf_io_check( nf90_put_var(nc%id, nc%GMescape_varid, self%GMescape, start=[tslot]), "netcdf_io_write_hdr_system nf90_put_var GMescape_varid" ) end if - ! Set the status flag to INACTIVE by default - call netcdf_io_check( nf90_inquire_dimension(nc%id, nc%name_dimid, len=idmax), "netcdf_io_get_t0_values_system name_dimid" ) - call netcdf_io_check( nf90_put_var(nc%id, nc%status_varid, [(INACTIVE, i=1,idmax)], start=[1,tslot], count=[idmax,1]), "netcdf_io_write_info_body nf90_put_var status_varid" ) - return end subroutine swiftest_io_netcdf_write_hdr_system @@ -1750,7 +1858,7 @@ module subroutine swiftest_io_netcdf_write_info_body(self, nc, param) class is (swiftest_body) associate(n => self%nbody, tslot => nc%tslot) if (n == 0) return - call swiftest_util_sort(self%id(1:n), ind) + call util_sort(self%id(1:n), ind) call nc%get_idvals() do i = 1, n @@ -1871,7 +1979,7 @@ module subroutine swiftest_io_param_reader(self, unit, iotype, v_list, iostat, i integer(I4B), intent(out) :: iostat !! IO status code character(len=*), intent(inout) :: iomsg !! Message to pass if iostat /= 0 ! Internals - logical :: tstart_set = .false. !! Is the final time set in the input file? + logical :: tstart_set = .false. !! Is the final time set in the input file? logical :: tstop_set = .false. !! Is the final time set in the input file? logical :: dt_set = .false. !! Is the step size set in the input file? integer(I4B) :: ilength, ifirst, ilast, i !! Variables used to parse input file @@ -1882,10 +1990,16 @@ module subroutine swiftest_io_param_reader(self, unit, iotype, v_list, iostat, i logical :: seed_set = .false. !! Is the random seed set in the input file? character(len=:), allocatable :: integrator real(DP) :: tratio, y - - - ! Parse the file line by line, extracting tokens then matching them up with known parameters if possible +#ifdef COARRAY + type(swiftest_parameters), codimension[*], save :: coparam + + if (this_image() == 1) then + coparam = self + associate(param => coparam) +#else associate(param => self) +#endif + ! Parse the file line by line, extracting tokens then matching them up with known parameters if possible call random_seed(size = nseeds) if (allocated(param%seed)) deallocate(param%seed) allocate(param%seed(nseeds)) @@ -2060,6 +2174,9 @@ module subroutine swiftest_io_param_reader(self, unit, iotype, v_list, iostat, i case ("ENCOUNTER_SAVE") call swiftest_io_toupper(param_value) read(param_value, *) param%encounter_save + case ("COARRAY") + call swiftest_io_toupper(param_value) + if (param_value == "YES" .or. param_value == 'T') param%lcoarray = .true. case("SEED") read(param_value, *) nseeds_from_file ! Because the number of seeds can vary between compilers/systems, we need to make sure we can handle cases in which the input file has a different @@ -2198,9 +2315,6 @@ module subroutine swiftest_io_param_reader(self, unit, iotype, v_list, iostat, i ! Calculate the G for the nbody_system units param%GU = GC / (param%DU2M**3 / (param%MU2KG * param%TU2S**2)) - ! A minimal log of collision outcomes is stored in the following log file - ! More complete data on collisions is stored in the NetCDF output files - call swiftest_io_log_start(param, COLLISION_LOG_OUT, "Collision logfile") if ((param%encounter_save /= "NONE") .and. & (param%encounter_save /= "TRAJECTORY") .and. & @@ -2306,14 +2420,57 @@ module subroutine swiftest_io_param_reader(self, unit, iotype, v_list, iostat, i param%lencounter_sas_pltp = .false. end select + + if (param%lcoarray) then +#ifdef COARRAY + if (num_images() == 1) then + write(iomsg, *) "Only one Coarray image detected. Coarrays will not be used." + param%lcoarray = .false. + end if + + select case(param%integrator) + case(INT_WHM, INT_RMVS, INT_HELIO) + case default + write(iomsg, *) "Coarray-based parallelization of test particles are not compatible with this integrator. This parameter will be ignored." + param%lcoarray = .false. + end select +#else + write(iomsg,*) "Coarray capability not detected. Swiftest must be compiled with Coarrays enabled. to use this feature." + param%lcoarray = .false. +#endif + end if + iostat = 0 + end associate + +#ifdef COARRAY + end if ! this_image() == 1 + call coparam%coclone() +#endif + select type(param => self) + type is (swiftest_parameters) +#ifdef COARRAY + param = coparam +#endif call param%set_display(param%display_style) - - ! Print the contents of the parameter file to standard output - if (.not.param%lrestart) call param%writer(unit = param%display_unit, iotype = "none", v_list = [0], iostat = iostat, iomsg = iomsg) - end associate + if (.not.param%lrestart) then +#ifdef COARRAY + if (this_image() == 1 .or. param%log_output) then +#endif + call param%writer(unit = param%display_unit, iotype = "none", v_list = [0], iostat = iostat, iomsg = iomsg) + if (param%log_output) flush(param%display_unit) +#ifdef COARRAY + end if !(this_image() == 1) + write(COLLISION_LOG_OUT,'("collision_coimage",I0.3,".log")') this_image() +#endif + ! A minimal log of collision outcomes is stored in the following log file + ! More complete data on collisions is stored in the NetCDF output files + call swiftest_io_log_start(param, COLLISION_LOG_OUT, "Collision logfile") + end if + ! Print the contents of the parameter file to standard output + end select return 667 continue @@ -2409,6 +2566,7 @@ module subroutine swiftest_io_param_writer(self, unit, iotype, v_list, iostat, i call io_param_writer_one("ENCOUNTER_CHECK_PLPL", param%encounter_check_plpl, unit) call io_param_writer_one("ENCOUNTER_CHECK_PLTP", param%encounter_check_pltp, unit) call io_param_writer_one("ENCOUNTER_SAVE", param%encounter_save, unit) + call io_param_writer_one("COARRAY", param%lcoarray, unit) if (param%lenergy) then call io_param_writer_one("FIRSTENERGY", param%lfirstenergy, unit) @@ -2734,14 +2892,15 @@ module subroutine swiftest_io_read_in_cb(self, param) end subroutine swiftest_io_read_in_cb - module subroutine swiftest_io_read_in_system(self, param) + module subroutine swiftest_io_read_in_system(self, nc, param) !! author: David A. Minton and Carlisle A. Wishard !! !! Reads in the nbody_system from input files implicit none ! Arguments - class(swiftest_nbody_system), intent(inout) :: self - class(swiftest_parameters), intent(inout) :: param + class(swiftest_nbody_system), intent(inout) :: self + class(swiftest_netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular NetCDF dataset + class(swiftest_parameters), intent(inout) :: param ! Internals integer(I4B) :: ierr, i class(swiftest_parameters), allocatable :: tmp_param @@ -2764,13 +2923,13 @@ module subroutine swiftest_io_read_in_system(self, param) self%E_untracked = param%E_untracked else allocate(tmp_param, source=param) - self%system_history%nc%file_name = param%nc_in + nc%file_name = param%nc_in tmp_param%out_form = param%in_form if (.not. param%lrestart) then ! Turn off energy computation so we don't have to feed it into the initial conditions tmp_param%lenergy = .false. end if - ierr = self%read_frame(self%system_history%nc, tmp_param) + ierr = self%read_frame(nc, tmp_param) deallocate(tmp_param) if (ierr /=0) call base_util_exit(FAILURE) end if @@ -2938,6 +3097,13 @@ module subroutine swiftest_io_set_display_param(self, display_style) self%display_unit = OUTPUT_UNIT !! stdout from iso_fortran_env self%log_output = .false. case ('COMPACT', 'PROGRESS') +#ifdef COARRAY + if (self%lcoarray) then + write(SWIFTEST_LOG_FILE,'("swiftest_coimage",I0.3,".log")') this_image() + else + write(SWIFTEST_LOG_FILE,'("swiftest.log")') + end if +#endif inquire(file=SWIFTEST_LOG_FILE, exist=fileExists) if (self%lrestart.and.fileExists) then open(unit=SWIFTEST_LOG_OUT, file=SWIFTEST_LOG_FILE, status="OLD", position="APPEND", err = 667, iomsg = errmsg) @@ -2986,7 +3152,7 @@ module subroutine swiftest_io_toupper(string) end subroutine swiftest_io_toupper - module subroutine swiftest_io_write_frame_system(self, param) + module subroutine swiftest_io_initialize_output_file_system(self, nc, param) !! author: The Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott !! !! Write a frame (header plus records for each massive body and active test particle) to output binary file @@ -2996,17 +3162,21 @@ module subroutine swiftest_io_write_frame_system(self, param) !! Adapted from Hal Levison's Swift routine io_write_frame.f implicit none ! Arguments - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody_system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody_system object + class(swiftest_netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular NetCDF dataset + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters ! Internals logical, save :: lfirst = .true. !! Flag to determine if this is the first call of this method character(len=STRMAX) :: errmsg logical :: fileExists - associate (nc => self%system_history%nc, pl => self%pl, tp => self%tp, npl => self%pl%nbody, ntp => self%tp%nbody) + associate (pl => self%pl, tp => self%tp, npl => self%pl%nbody, ntp => self%tp%nbody) nc%file_name = param%outfile if (lfirst) then inquire(file=param%outfile, exist=fileExists) +#ifdef COARRAY + if (this_image() /= 1) param%out_stat = 'APPEND' +#endif select case(param%out_stat) case('APPEND') @@ -3028,7 +3198,6 @@ module subroutine swiftest_io_write_frame_system(self, param) lfirst = .false. end if - call self%write_frame(nc, param) end associate return @@ -3036,6 +3205,6 @@ module subroutine swiftest_io_write_frame_system(self, param) 667 continue write(*,*) "Error writing nbody_system frame: " // trim(adjustl(errmsg)) call base_util_exit(FAILURE) - end subroutine swiftest_io_write_frame_system + end subroutine swiftest_io_initialize_output_file_system end submodule s_swiftest_io diff --git a/src/swiftest/swiftest_kick.f90 b/src/swiftest/swiftest_kick.f90 index 54da2f82a..430679b43 100644 --- a/src/swiftest/swiftest_kick.f90 +++ b/src/swiftest/swiftest_kick.f90 @@ -22,7 +22,9 @@ module subroutine swiftest_kick_getacch_int_pl(self, param) class(swiftest_parameters), intent(inout) :: param !! Current swiftest run configuration parameters ! Internals logical, save :: lfirst = .true. - +#ifdef PROFILE + type(walltimer), save :: timer +#endif if (param%lflatten_interactions) then if (param%lclose) then diff --git a/src/swiftest/swiftest_module.f90 b/src/swiftest/swiftest_module.f90 index 4ac6cb3c3..c86f86dd1 100644 --- a/src/swiftest/swiftest_module.f90 +++ b/src/swiftest/swiftest_module.f90 @@ -43,6 +43,9 @@ module swiftest use io_progress_bar use netcdf_io use solver +#ifdef COARRAY + use coarray +#endif !use advisor_annotate !$ use omp_lib implicit none @@ -54,6 +57,9 @@ module swiftest procedure :: get_valid_masks => swiftest_io_netcdf_get_valid_masks !! Gets logical masks indicating which bodies are valid pl and tp type at the current time procedure :: open => swiftest_io_netcdf_open !! Opens a NetCDF file and does the variable inquiries to activate variable ids procedure :: flush => swiftest_io_netcdf_flush !! Flushes a NetCDF file by closing it then opening it again +#ifdef COARRAY + procedure :: coclone => swiftest_coarray_coclone_nc +#endif end type swiftest_netcdf_parameters @@ -92,9 +98,11 @@ module swiftest !> An abstract class for a generic collection of Swiftest bodies - type, abstract, extends(base_multibody) :: swiftest_body + type, abstract, extends(base_object) :: swiftest_body !! Superclass that defines the generic elements of a Swiftest particle logical :: lfirst = .true. !! Run the current step as a first + integer(I4B) :: nbody = 0 !! Number of bodies + integer(I4B), dimension(:), allocatable :: id !! Identifier type(swiftest_particle_info), dimension(:), allocatable :: info !! Particle metadata information logical, dimension(:), allocatable :: lmask !! Logical mask used to select a subset of bodies when performing certain operations (drift, kick, accel, etc.) integer(I4B), dimension(:), allocatable :: status !! An integrator-specific status indicator @@ -148,12 +156,15 @@ module swiftest procedure :: fill => swiftest_util_fill_body !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) procedure :: get_peri => swiftest_util_peri_body !! Determine nbody_system pericenter passages for test particles procedure :: resize => swiftest_util_resize_body !! Checks the current size of a Swiftest body against the requested size and resizes it if it is too small. - procedure :: set_ir3 => swiftest_util_set_ir3h !! Sets the inverse heliocentric radius term (1/rh**3) procedure :: sort => swiftest_util_sort_body !! Sorts body arrays by a sortable componen procedure :: rearrange => swiftest_util_sort_rearrange_body !! Rearranges the order of array elements of body based on an input index array. Used in sorting methods procedure :: spill => swiftest_util_spill_body !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) generic :: read_frame => read_frame_bin !! Add the generic read frame for Fortran binary files +#ifdef COARRAY + procedure :: coclone => swiftest_coarray_coclone_body !! Clones the image 1 body object to all other images in the coarray structure. + procedure :: cocollect => swiftest_coarray_cocollect_body !! Collects all body object array components from all images and combines them into the image 1 body object +#endif end type swiftest_body @@ -211,6 +222,10 @@ module swiftest procedure :: read_in => swiftest_io_read_in_cb !! Read in central body initial conditions from an ASCII file procedure :: write_frame => swiftest_io_netcdf_write_frame_cb !! I/O routine for writing out a single frame of time-series data for all bodies in the system in NetCDF format procedure :: write_info => swiftest_io_netcdf_write_info_cb !! Dump contents of particle information metadata to file + +#ifdef COARRAY + procedure :: coclone => swiftest_coarray_coclone_cb !! Clones the image 1 body object to all other images in the coarray structure. +#endif end type swiftest_cb @@ -270,6 +285,9 @@ module swiftest procedure :: rearrange => swiftest_util_sort_rearrange_pl !! Rearranges the order of array elements of body based on an input index array. Used in sorting methods procedure :: spill => swiftest_util_spill_pl !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) generic :: set_renc => set_renc_I4B, set_renc_DP +#ifdef COARRAY + procedure :: coclone => swiftest_coarray_coclone_pl !! Clones the image 1 body object to all other images in the coarray structure. +#endif end type swiftest_pl @@ -300,6 +318,10 @@ module swiftest procedure :: sort => swiftest_util_sort_tp !! Sorts body arrays by a sortable component procedure :: rearrange => swiftest_util_sort_rearrange_tp !! Rearranges the order of array elements of body based on an input index array. Used in sorting methods procedure :: spill => swiftest_util_spill_tp !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) +#ifdef COARRAY + procedure :: coclone => swiftest_coarray_coclone_tp !! Clones the image 1 object to all other images in the coarray structure. + procedure :: cocollect => swiftest_coarray_cocollect_tp !! Collects all object array components from all images and combines them into the image 1 object +#endif end type swiftest_tp @@ -323,7 +345,6 @@ module swiftest class(collision_basic), allocatable :: collider !! Collision system object class(encounter_storage), allocatable :: encounter_history !! Stores encounter history for later retrieval and saving to file class(collision_storage), allocatable :: collision_history !! Stores encounter history for later retrieval and saving to file - class(swiftest_storage), allocatable :: system_history !! Stores the system history between output dumps integer(I4B) :: maxid = -1 !! The current maximum particle id number real(DP) :: t = -1.0_DP !! Integration current time @@ -384,23 +405,28 @@ module swiftest procedure :: dump => swiftest_io_dump_system !! Dump the state of the nbody_system to a file procedure :: get_t0_values => swiftest_io_netcdf_get_t0_values_system !! Validates the dump file to check whether the dump file initial conditions duplicate the last frame of the netcdf output. procedure :: read_frame => swiftest_io_netcdf_read_frame_system !! Read in a frame of input data from file - procedure :: write_frame_netcdf => swiftest_io_netcdf_write_frame_system !! Write a frame of input data from file procedure :: read_hdr => swiftest_io_netcdf_read_hdr_system !! Read a header for an output frame in NetCDF format procedure :: write_hdr => swiftest_io_netcdf_write_hdr_system !! Write a header for an output frame in NetCDF format procedure :: read_particle_info => swiftest_io_netcdf_read_particle_info_system !! Read in particle metadata from file procedure :: read_in => swiftest_io_read_in_system !! Reads the initial conditions for an nbody system - procedure :: write_frame_system => swiftest_io_write_frame_system !! Write a frame of input data from file + procedure :: write_frame => swiftest_io_netcdf_write_frame_system !! Write a frame of input data from file procedure :: obl_pot => swiftest_obl_pot_system !! Compute the contribution to the total gravitational potential due solely to the oblateness of the central body - procedure :: dealloc => swiftest_util_dealloc_system !! Deallocates all allocatables and resets all values to defaults. Acts as a base for a finalizer + procedure :: dealloc => swiftest_util_dealloc_system !! Deallocates all allocatables and resets all values to defaults. Acts as a base for a finalizer procedure :: get_energy_and_momentum => swiftest_util_get_energy_and_momentum_system !! Calculates the total nbody_system energy and momentum procedure :: get_idvals => swiftest_util_get_idvalues_system !! Returns an array of all id values in use in the nbody_system procedure :: rescale => swiftest_util_rescale_system !! Rescales the nbody_system into a new set of units + procedure :: initialize_output_file => swiftest_io_initialize_output_file_system !! Write a frame of input data from file procedure :: initialize => swiftest_util_setup_initialize_system !! Initialize the nbody_system from input files procedure :: init_particle_info => swiftest_util_setup_initialize_particle_info_system !! Initialize the nbody_system from input files ! procedure :: step_spin => tides_step_spin_system !! Steps the spins of the massive & central bodies due to tides. procedure :: set_msys => swiftest_util_set_msys !! Sets the value of msys from the masses of nbody_system bodies. procedure :: validate_ids => swiftest_util_valid_id_system !! Validate the numerical ids passed to the nbody_system and save the maximum value - generic :: write_frame => write_frame_system, write_frame_netcdf !! Generic method call for reading a frame of output data +#ifdef COARRAY + procedure :: coclone => swiftest_coarray_coclone_system !! Clones the image 1 body object to all other images in the coarray structure. + procedure :: coarray_collect => swiftest_coarray_collect_system !! Collects all the test particles from other images into the image #1 test particle system + procedure :: coarray_distribute => swiftest_coarray_distribute_system !! Distributes test particles from image #1 out to all images. + procedure :: coarray_balance => swiftest_coarray_balance_system !! Checks whether or not the test particle coarrays need to be rebalanced. +#endif end type swiftest_nbody_system @@ -442,11 +468,11 @@ end subroutine abstract_set_mu subroutine abstract_step_body(self, nbody_system, param, t, dt) import DP, swiftest_body, swiftest_nbody_system, swiftest_parameters implicit none - class(swiftest_body), intent(inout) :: self !! Swiftest body object + class(swiftest_body), intent(inout) :: self !! Swiftest body object class(swiftest_nbody_system), intent(inout) :: nbody_system !! Swiftest nbody_system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - real(DP), intent(in) :: t !! Simulation time - real(DP), intent(in) :: dt !! Current stepsize + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + real(DP), intent(in) :: t !! Simulation time + real(DP), intent(in) :: dt !! Current stepsize end subroutine abstract_step_body subroutine abstract_step_system(self, param, t, dt) @@ -459,7 +485,6 @@ subroutine abstract_step_system(self, param, t, dt) end subroutine abstract_step_system end interface - interface module subroutine swiftest_discard_pl(self, nbody_system, param) implicit none @@ -500,11 +525,11 @@ module subroutine swiftest_drift_body(self, nbody_system, param, dt) real(DP), intent(in) :: dt !! Stepsize end subroutine swiftest_drift_body - pure elemental module subroutine swiftest_drift_one(mu, px, py, pz, vx, vy, vz, dt, iflag) + pure elemental module subroutine swiftest_drift_one(mu, rx, ry, rz, vx, vy, vz, dt, iflag) !$omp declare simd(swiftest_drift_one) implicit none real(DP), intent(in) :: mu !! G * (Mcb + m), G = gravitational constant, Mcb = mass of central body, m = mass of body to drift - real(DP), intent(inout) :: px, py, pz, vx, vy, vz !! Position and velocity of body to drift + real(DP), intent(inout) :: rx, ry, rz, vx, vy, vz !! Position and velocity of body to drift real(DP), intent(in) :: dt !! Step size integer(I4B), intent(out) :: iflag !! iflag : error status flag for Danby drift (0 = OK, nonzero = ERROR) end subroutine swiftest_drift_one @@ -592,10 +617,11 @@ module subroutine swiftest_io_dump_param(self, param_file_name) character(len=*), intent(in) :: param_file_name !! Parameter input file name (i.e. param.in) end subroutine swiftest_io_dump_param - module subroutine swiftest_io_dump_system(self, param) + module subroutine swiftest_io_dump_system(self, param, system_history) implicit none - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody_system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody_system object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(swiftest_storage), intent(inout) :: system_history !! Stores the system history between output dumps end subroutine swiftest_io_dump_system module subroutine swiftest_io_dump_storage(self, param) @@ -639,10 +665,11 @@ module subroutine swiftest_io_netcdf_flush(self, param) class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters end subroutine swiftest_io_netcdf_flush - module subroutine swiftest_io_netcdf_get_t0_values_system(self, param) + module subroutine swiftest_io_netcdf_get_t0_values_system(self, nc, param) implicit none - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object + class(swiftest_netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular NetCDF dataset + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters end subroutine swiftest_io_netcdf_get_t0_values_system module subroutine swiftest_io_netcdf_get_valid_masks(self, plmask, tpmask) @@ -837,9 +864,10 @@ module subroutine swiftest_io_read_in_param(self, param_file_name) character(len=*), intent(in) :: param_file_name !! Parameter input file name (i.e. param.in) end subroutine swiftest_io_read_in_param - module subroutine swiftest_io_read_in_system(self, param) + module subroutine swiftest_io_read_in_system(self, nc, param) implicit none - class(swiftest_nbody_system), intent(inout) :: self + class(swiftest_nbody_system), intent(inout) :: self + class(swiftest_netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular NetCDF dataset class(swiftest_parameters), intent(inout) :: param end subroutine swiftest_io_read_in_system @@ -870,11 +898,12 @@ module subroutine swiftest_io_toupper(string) character(*), intent(inout) :: string !! String to make upper case end subroutine swiftest_io_toupper - module subroutine swiftest_io_write_frame_system(self, param) + module subroutine swiftest_io_initialize_output_file_system(self, nc, param) implicit none - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody_system object + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody_system object + class(swiftest_netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular NetCDF dataset class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine swiftest_io_write_frame_system + end subroutine swiftest_io_initialize_output_file_system module subroutine swiftest_kick_getacch_int_pl(self, param) implicit none @@ -1002,22 +1031,22 @@ pure module subroutine swiftest_orbel_scget(angle, sx, cx) real(DP), intent(out) :: sx, cx end subroutine swiftest_orbel_scget - pure elemental module subroutine swiftest_orbel_xv2aeq(mu, px, py, pz, vx, vy, vz, a, e, q) + pure elemental module subroutine swiftest_orbel_xv2aeq(mu, rx, ry, rz, vx, vy, vz, a, e, q) !$omp declare simd(swiftest_orbel_xv2aeq) implicit none real(DP), intent(in) :: mu !! Gravitational constant - real(DP), intent(in) :: px,py,pz !! Position vector + real(DP), intent(in) :: rx,ry,rz !! Position vector real(DP), intent(in) :: vx,vy,vz !! Velocity vector real(DP), intent(out) :: a !! semimajor axis real(DP), intent(out) :: e !! eccentricity real(DP), intent(out) :: q !! periapsis end subroutine swiftest_orbel_xv2aeq - pure module subroutine swiftest_orbel_xv2aqt(mu, px, py, pz, vx, vy, vz, a, q, capm, tperi) + pure module subroutine swiftest_orbel_xv2aqt(mu, rx, ry, rz, vx, vy, vz, a, q, capm, tperi) !$omp declare simd(swiftest_orbel_xv2aqt) implicit none real(DP), intent(in) :: mu !! Gravitational constant - real(DP), intent(in) :: px,py,pz !! Position vector + real(DP), intent(in) :: rx,ry,rz !! Position vector real(DP), intent(in) :: vx,vy,vz !! Velocity vector real(DP), intent(out) :: a !! semimajor axis real(DP), intent(out) :: q !! periapsis @@ -1025,10 +1054,10 @@ pure module subroutine swiftest_orbel_xv2aqt(mu, px, py, pz, vx, vy, vz, a, q, c real(DP), intent(out) :: tperi !! time of pericenter passage end subroutine swiftest_orbel_xv2aqt - pure module subroutine swiftest_orbel_xv2el(mu, px, py, pz, vx, vy, vz, a, e, inc, capom, omega, capm, varpi, lam, f, cape, capf) + pure module subroutine swiftest_orbel_xv2el(mu, rx, ry, rz, vx, vy, vz, a, e, inc, capom, omega, capm, varpi, lam, f, cape, capf) implicit none real(DP), intent(in) :: mu !! Gravitational constant - real(DP), intent(in) :: px,py,pz !! Position vector + real(DP), intent(in) :: rx,ry,rz !! Position vector real(DP), intent(in) :: vx,vy,vz !! Velocity vector real(DP), intent(out) :: a !! semimajor axis real(DP), intent(out) :: e !! eccentricity @@ -1059,7 +1088,7 @@ end subroutine swiftest_util_setup_body module subroutine swiftest_util_setup_construct_system(nbody_system, param) implicit none class(swiftest_nbody_system), allocatable, intent(inout) :: nbody_system !! Swiftest nbody_system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters end subroutine swiftest_util_setup_construct_system module subroutine swiftest_util_setup_initialize_particle_info_system(self, param) @@ -1068,10 +1097,11 @@ module subroutine swiftest_util_setup_initialize_particle_info_system(self, para class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters end subroutine swiftest_util_setup_initialize_particle_info_system - module subroutine swiftest_util_setup_initialize_system(self, param) + module subroutine swiftest_util_setup_initialize_system(self, system_history, param) implicit none - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody_system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody_system object + class(swiftest_storage), allocatable, intent(inout) :: system_history !! Stores the system history between output dumps + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters end subroutine swiftest_util_setup_initialize_system module subroutine swiftest_util_setup_pl(self, n, param) @@ -1098,62 +1128,22 @@ module subroutine swiftest_user_kick_getacch_body(self, nbody_system, param, t, end subroutine swiftest_user_kick_getacch_body end interface - interface swiftest_util_append - module subroutine swiftest_util_append_arr_char_string(arr, source, nold, nsrc, lsource_mask) + interface util_append + module subroutine swiftest_util_append_arr_info(arr, source, nold, lsource_mask) implicit none - character(len=STRMAX), dimension(:), allocatable, intent(inout) :: arr !! Destination array - character(len=STRMAX), dimension(:), allocatable, intent(in) :: source !! Array to append - integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively - logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to - end subroutine swiftest_util_append_arr_char_string - - module subroutine swiftest_util_append_arr_DP(arr, source, nold, nsrc, lsource_mask) - implicit none - real(DP), dimension(:), allocatable, intent(inout) :: arr !! Destination array - real(DP), dimension(:), allocatable, intent(in) :: source !! Array to append - integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively - logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to - end subroutine swiftest_util_append_arr_DP - - module subroutine swiftest_util_append_arr_DPvec(arr, source, nold, nsrc, lsource_mask) - implicit none - real(DP), dimension(:,:), allocatable, intent(inout) :: arr !! Destination array - real(DP), dimension(:,:), allocatable, intent(in) :: source !! Array to append - integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively - logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to - end subroutine swiftest_util_append_arr_DPvec - - module subroutine swiftest_util_append_arr_I4B(arr, source, nold, nsrc, lsource_mask) - implicit none - integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), allocatable, intent(in) :: source !! Array to append - integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively - logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to - end subroutine swiftest_util_append_arr_I4B - - module subroutine swiftest_util_append_arr_info(arr, source, nold, nsrc, lsource_mask) - implicit none - type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: arr !! Destination array - type(swiftest_particle_info), dimension(:), allocatable, intent(in) :: source !! Array to append - integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively - logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: arr !! Destination array + type(swiftest_particle_info), dimension(:), allocatable, intent(in) :: source !! Array to append + integer(I4B), intent(in), optional :: nold !! Extent of original array. If passed, the source array will begin at arr(nold+1). Otherwise, the size of arr will be used. + logical, dimension(:), intent(in), optional :: lsource_mask !! Logical mask indicating which elements to append to end subroutine swiftest_util_append_arr_info - module subroutine swiftest_util_append_arr_kin(arr, source, nold, nsrc, lsource_mask) + module subroutine swiftest_util_append_arr_kin(arr, source, nold, lsource_mask) implicit none - type(swiftest_kinship), dimension(:), allocatable, intent(inout) :: arr !! Destination array - type(swiftest_kinship), dimension(:), allocatable, intent(in) :: source !! Array to append - integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively - logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + type(swiftest_kinship), dimension(:), allocatable, intent(inout) :: arr !! Destination array + type(swiftest_kinship), dimension(:), allocatable, intent(in) :: source !! Array to append + integer(I4B), intent(in), optional :: nold !! Extent of original array. If passed, the source array will begin at arr(nold+1). Otherwise, the size of arr will be used. + logical, dimension(:), intent(in), optional :: lsource_mask !! Logical mask indicating which elements to append to end subroutine swiftest_util_append_arr_kin - - module subroutine swiftest_util_append_arr_logical(arr, source, nold, nsrc, lsource_mask) - implicit none - logical, dimension(:), allocatable, intent(inout) :: arr !! Destination array - logical, dimension(:), allocatable, intent(in) :: source !! Array to append - integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively - logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to - end subroutine swiftest_util_append_arr_logical end interface interface @@ -1308,40 +1298,12 @@ module subroutine swiftest_util_fill_tp(self, inserts, lfill_list) end subroutine swiftest_util_fill_tp end interface - interface swiftest_util_fill - module subroutine swiftest_util_fill_arr_char_string(keeps, inserts, lfill_list) - implicit none - character(len=STRMAX), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - character(len=STRMAX), dimension(:), allocatable, intent(in) :: inserts !! Array of values to insert into keep - logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - end subroutine swiftest_util_fill_arr_char_string - - module subroutine swiftest_util_fill_arr_DP(keeps, inserts, lfill_list) - implicit none - real(DP), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - real(DP), dimension(:), allocatable, intent(in) :: inserts !! Array of values to insert into keep - logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - end subroutine swiftest_util_fill_arr_DP - - module subroutine swiftest_util_fill_arr_DPvec(keeps, inserts, lfill_list) - implicit none - real(DP), dimension(:,:), allocatable, intent(inout) :: keeps !! Array of values to keep - real(DP), dimension(:,:), allocatable, intent(in) :: inserts !! Array of values to insert into keep - logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - end subroutine swiftest_util_fill_arr_DPvec - - module subroutine swiftest_util_fill_arr_I4B(keeps, inserts, lfill_list) - implicit none - integer(I4B), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - integer(I4B), dimension(:), allocatable, intent(in) :: inserts !! Array of values to insert into keep - logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - end subroutine swiftest_util_fill_arr_I4B - + interface util_fill module subroutine swiftest_util_fill_arr_info(keeps, inserts, lfill_list) implicit none type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep type(swiftest_particle_info), dimension(:), allocatable, intent(in) :: inserts !! Array of values to insert into keep - logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps + logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps end subroutine swiftest_util_fill_arr_info module subroutine swiftest_util_fill_arr_kin(keeps, inserts, lfill_list) @@ -1350,13 +1312,6 @@ module subroutine swiftest_util_fill_arr_kin(keeps, inserts, lfill_list) type(swiftest_kinship), dimension(:), allocatable, intent(in) :: inserts !! Array of values to insert into keep logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps end subroutine swiftest_util_fill_arr_kin - - module subroutine swiftest_util_fill_arr_logical(keeps, inserts, lfill_list) - implicit none - logical, dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - logical, dimension(:), allocatable, intent(in) :: inserts !! Array of values to insert into keep - logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - end subroutine swiftest_util_fill_arr_logical end interface interface @@ -1501,31 +1456,7 @@ end subroutine swiftest_util_reset_kinship_pl end interface - interface swiftest_util_resize - module subroutine swiftest_util_resize_arr_char_string(arr, nnew) - implicit none - character(len=STRMAX), dimension(:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size - end subroutine swiftest_util_resize_arr_char_string - - module subroutine swiftest_util_resize_arr_DP(arr, nnew) - implicit none - real(DP), dimension(:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size - end subroutine swiftest_util_resize_arr_DP - - module subroutine swiftest_util_resize_arr_DPvec(arr, nnew) - implicit none - real(DP), dimension(:,:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size - end subroutine swiftest_util_resize_arr_DPvec - - module subroutine swiftest_util_resize_arr_I4B(arr, nnew) - implicit none - integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size - end subroutine swiftest_util_resize_arr_I4B - + interface util_resize module subroutine swiftest_util_resize_arr_info(arr, nnew) implicit none type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: arr !! Array to resize @@ -1537,12 +1468,6 @@ module subroutine swiftest_util_resize_arr_kin(arr, nnew) type(swiftest_kinship), dimension(:), allocatable, intent(inout) :: arr !! Array to resize integer(I4B), intent(in) :: nnew !! New size end subroutine swiftest_util_resize_arr_kin - - module subroutine swiftest_util_resize_arr_logical(arr, nnew) - implicit none - logical, dimension(:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size - end subroutine swiftest_util_resize_arr_logical end interface interface @@ -1653,98 +1578,16 @@ end subroutine swiftest_util_snapshot_save module subroutine swiftest_util_snapshot_system(self, param, nbody_system, t, arg) implicit none - class(swiftest_storage), intent(inout) :: self !! Swiftest storage object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - class(swiftest_nbody_system), intent(inout) :: nbody_system !! Swiftest nbody system object to store - real(DP), intent(in), optional :: t !! Time of snapshot if different from nbody_system time - character(*), intent(in), optional :: arg !! Optional argument (needed for extended storage type used in encounter snapshots) + class(swiftest_storage), intent(inout) :: self !! Swiftest storage object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(swiftest_nbody_system), intent(inout) :: nbody_system !! Swiftest nbody system object to store + real(DP), intent(in), optional :: t !! Time of snapshot if different from nbody_system time + character(*), intent(in), optional :: arg !! Optional argument (needed for extended storage type used in collision snapshots) end subroutine swiftest_util_snapshot_system end interface - interface swiftest_util_sort - pure module subroutine swiftest_util_sort_i4b(arr) - implicit none - integer(I4B), dimension(:), intent(inout) :: arr - end subroutine swiftest_util_sort_i4b - - pure module subroutine swiftest_util_sort_index_i4b(arr,ind) - implicit none - integer(I4B), dimension(:), intent(in) :: arr - integer(I4B), dimension(:), allocatable, intent(inout) :: ind - end subroutine swiftest_util_sort_index_i4b - - pure module subroutine swiftest_util_sort_index_I4B_I8Bind(arr,ind) - implicit none - integer(I4B), dimension(:), intent(in) :: arr - integer(I8B), dimension(:), allocatable, intent(inout) :: ind - end subroutine swiftest_util_sort_index_I4b_I8Bind - - pure module subroutine swiftest_util_sort_index_I8B_I8Bind(arr,ind) - implicit none - integer(I8B), dimension(:), intent(in) :: arr - integer(I8B), dimension(:), allocatable, intent(inout) :: ind - end subroutine swiftest_util_sort_index_I8B_I8Bind - - pure module subroutine swiftest_util_sort_sp(arr) - implicit none - real(SP), dimension(:), intent(inout) :: arr - end subroutine swiftest_util_sort_sp - - pure module subroutine swiftest_util_sort_index_sp(arr,ind) - implicit none - real(SP), dimension(:), intent(in) :: arr - integer(I4B), dimension(:), allocatable, intent(inout) :: ind - end subroutine swiftest_util_sort_index_sp - - pure module subroutine swiftest_util_sort_dp(arr) - implicit none - real(DP), dimension(:), intent(inout) :: arr - end subroutine swiftest_util_sort_dp - - pure module subroutine swiftest_util_sort_index_dp(arr,ind) - implicit none - real(DP), dimension(:), intent(in) :: arr - integer(I4B), dimension(:), allocatable, intent(inout) :: ind - end subroutine swiftest_util_sort_index_dp - end interface swiftest_util_sort - - interface swiftest_util_sort_rearrange - pure module subroutine swiftest_util_sort_rearrange_arr_char_string(arr, ind, n) - implicit none - character(len=STRMAX), dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange - end subroutine swiftest_util_sort_rearrange_arr_char_string - - pure module subroutine swiftest_util_sort_rearrange_arr_DP(arr, ind, n) - implicit none - real(DP), dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange - end subroutine swiftest_util_sort_rearrange_arr_DP - - pure module subroutine swiftest_util_sort_rearrange_arr_DPvec(arr, ind, n) - implicit none - real(DP), dimension(:,:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange - end subroutine swiftest_util_sort_rearrange_arr_DPvec - - pure module subroutine swiftest_util_sort_rearrange_arr_I4B(arr, ind, n) - implicit none - integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange - end subroutine swiftest_util_sort_rearrange_arr_I4B - - pure module subroutine swiftest_util_sort_rearrange_arr_I4B_I8Bind(arr, ind, n) - implicit none - integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I8B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I8B), intent(in) :: n !! Number of elements in arr and ind to rearrange - end subroutine swiftest_util_sort_rearrange_arr_I4B_I8Bind - + interface util_sort_rearrange module subroutine swiftest_util_sort_rearrange_arr_info(arr, ind, n) implicit none type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: arr !! Destination array @@ -1759,20 +1602,7 @@ pure module subroutine swiftest_util_sort_rearrange_arr_kin(arr, ind, n) integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange end subroutine swiftest_util_sort_rearrange_arr_kin - pure module subroutine swiftest_util_sort_rearrange_arr_logical(arr, ind, n) - implicit none - logical, dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange - end subroutine swiftest_util_sort_rearrange_arr_logical - - pure module subroutine swiftest_util_sort_rearrange_arr_logical_I8Bind(arr, ind, n) - implicit none - logical, dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I8B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I8B), intent(in) :: n !! Number of elements in arr and ind to rearrange - end subroutine swiftest_util_sort_rearrange_arr_logical_I8Bind - end interface swiftest_util_sort_rearrange + end interface util_sort_rearrange interface module subroutine swiftest_util_sort_rearrange_body(self, ind) @@ -1816,47 +1646,7 @@ end subroutine swiftest_util_sort_tp end interface - interface swiftest_util_spill - module subroutine swiftest_util_spill_arr_char_string(keeps, discards, lspill_list, ldestructive) - implicit none - character(len=STRMAX), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - character(len=STRMAX), dimension(:), allocatable, intent(inout) :: discards !! Array of discards - logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discardss - logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not - end subroutine swiftest_util_spill_arr_char_string - - module subroutine swiftest_util_spill_arr_DP(keeps, discards, lspill_list, ldestructive) - implicit none - real(DP), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - real(DP), dimension(:), allocatable, intent(inout) :: discards !! Array of discards - logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards - logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not - end subroutine swiftest_util_spill_arr_DP - - module subroutine swiftest_util_spill_arr_DPvec(keeps, discards, lspill_list, ldestructive) - implicit none - real(DP), dimension(:,:), allocatable, intent(inout) :: keeps !! Array of values to keep - real(DP), dimension(:,:), allocatable, intent(inout) :: discards !! Array discards - logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards - logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not - end subroutine swiftest_util_spill_arr_DPvec - - module subroutine swiftest_util_spill_arr_I4B(keeps, discards, lspill_list, ldestructive) - implicit none - integer(I4B), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - integer(I4B), dimension(:), allocatable, intent(inout) :: discards !! Array of discards - logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discardss - logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not - end subroutine swiftest_util_spill_arr_I4B - - module subroutine swiftest_util_spill_arr_I8B(keeps, discards, lspill_list, ldestructive) - implicit none - integer(I8B), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - integer(I8B), dimension(:), allocatable, intent(inout) :: discards !! Array of discards - logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discardss - logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not - end subroutine swiftest_util_spill_arr_I8B - + interface util_spill module subroutine swiftest_util_spill_arr_info(keeps, discards, lspill_list, ldestructive) implicit none type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep @@ -1872,14 +1662,6 @@ module subroutine swiftest_util_spill_arr_kin(keeps, discards, lspill_list, ldes logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discardss logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not end subroutine swiftest_util_spill_arr_kin - - module subroutine swiftest_util_spill_arr_logical(keeps, discards, lspill_list, ldestructive) - implicit none - logical, dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - logical, dimension(:), allocatable, intent(inout) :: discards !! Array of discards - logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discardss - logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not - end subroutine swiftest_util_spill_arr_logical end interface interface @@ -1909,22 +1691,6 @@ end subroutine swiftest_util_spill_tp end interface - interface swiftest_util_unique - module subroutine swiftest_util_unique_DP(input_array, output_array, index_map) - implicit none - real(DP), dimension(:), intent(in) :: input_array !! Unsorted input array - real(DP), dimension(:), allocatable, intent(out) :: output_array !! Sorted array of unique values - integer(I4B), dimension(:), allocatable, intent(out) :: index_map !! An array of the same size as input_array that such that any for any index i, output_array(index_map(i)) = input_array(i) - end subroutine swiftest_util_unique_DP - - module subroutine swiftest_util_unique_I4B(input_array, output_array, index_map) - implicit none - integer(I4B), dimension(:), intent(in) :: input_array !! Unsorted input array - integer(I4B), dimension(:), allocatable, intent(out) :: output_array !! Sorted array of unique values - integer(I4B), dimension(:), allocatable, intent(out) :: index_map !! An array of the same size as input_array that such that any for any index i, output_array(index_map(i)) = input_array(i) - end subroutine swiftest_util_unique_I4B - end interface swiftest_util_unique - interface module subroutine swiftest_util_valid_id_system(self, param) implicit none @@ -1937,6 +1703,106 @@ module subroutine swiftest_util_version() end subroutine swiftest_util_version end interface +#ifdef COARRAY + interface + module subroutine swiftest_coarray_balance_system(nbody_system, param) + !! author: David A. Minton + !! + !! Checks whether or not the system needs to be rebalance. Rebalancing occurs when the image with the smallest number of test particles + !! has <90% of that of the image with the largest number of test particles. + implicit none + ! Arguments + class(swiftest_nbody_system), intent(inout) :: nbody_system !! Swiftest nbody system + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine swiftest_coarray_balance_system + + module subroutine swiftest_coarray_collect_system(nbody_system, param) + implicit none + class(swiftest_nbody_system), intent(inout) :: nbody_system !! Swiftest nbody system + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine swiftest_coarray_collect_system + + module subroutine swiftest_coarray_distribute_system(nbody_system, param) + implicit none + class(swiftest_nbody_system), intent(inout) :: nbody_system !! Swiftest nbody system + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine swiftest_coarray_distribute_system + end interface + + interface coclone + module subroutine swiftest_coarray_component_clone_info(var,src_img) + implicit none + type(swiftest_particle_info), intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + end subroutine swiftest_coarray_component_clone_info + + module subroutine swiftest_coarray_component_clone_info_arr1D(var,src_img) + implicit none + type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + end subroutine swiftest_coarray_component_clone_info_arr1D + + module subroutine swiftest_coarray_component_clone_kin_arr1D(var,src_img) + implicit none + type(swiftest_kinship), dimension(:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: src_img + end subroutine swiftest_coarray_component_clone_kin_arr1D + end interface + + interface cocollect + module subroutine swiftest_coarray_component_collect_info_arr1D(var,dest_img) + implicit none + type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: var + integer(I4B), intent(in),optional :: dest_img + end subroutine + end interface + + interface + module subroutine swiftest_coarray_coclone_body(self) + implicit none + class(swiftest_body),intent(inout),codimension[*] :: self !! Swiftest body object + end subroutine swiftest_coarray_coclone_body + + module subroutine swiftest_coarray_coclone_cb(self) + implicit none + class(swiftest_cb),intent(inout),codimension[*] :: self !! Swiftest cb object + end subroutine swiftest_coarray_coclone_cb + + module subroutine swiftest_coarray_coclone_nc(self) + implicit none + class(swiftest_netcdf_parameters),intent(inout),codimension[*] :: self !! Swiftest body object + end subroutine swiftest_coarray_coclone_nc + + module subroutine swiftest_coarray_coclone_pl(self) + implicit none + class(swiftest_pl),intent(inout),codimension[*] :: self !! Swiftest pl object + end subroutine swiftest_coarray_coclone_pl + + module subroutine swiftest_coarray_coclone_tp(self) + implicit none + class(swiftest_tp),intent(inout),codimension[*] :: self !! Swiftest tp object + end subroutine swiftest_coarray_coclone_tp + + module subroutine swiftest_coarray_coclone_system(self) + implicit none + class(swiftest_nbody_system),intent(inout),codimension[*] :: self !! Swiftest nbody system object + end subroutine swiftest_coarray_coclone_system + + module subroutine swiftest_coarray_cocollect_body(self) + !! Collects all body object array components from all images and combines them into the image 1 body object + implicit none + class(swiftest_body),intent(inout), codimension[*] :: self !! Swiftest body object + end subroutine swiftest_coarray_cocollect_body + + module subroutine swiftest_coarray_cocollect_tp(self) + !! Collects all body object array components from all images and combines them into the image 1 body object + implicit none + class(swiftest_tp),intent(inout), codimension[*] :: self !! Swiftest tp object + end subroutine swiftest_coarray_cocollect_tp + end interface + +#endif + contains subroutine swiftest_final_kin(self) !! author: David A. Minton diff --git a/src/swiftest/swiftest_orbel.f90 b/src/swiftest/swiftest_orbel.f90 index 8e351e911..a3ec6f424 100644 --- a/src/swiftest/swiftest_orbel.f90 +++ b/src/swiftest/swiftest_orbel.f90 @@ -690,7 +690,7 @@ real(DP) pure function swiftest_orbel_fhybrid(e,n) end function swiftest_orbel_fhybrid - pure elemental module subroutine swiftest_orbel_xv2aeq(mu, px, py, pz, vx, vy, vz, a, e, q) + pure elemental module subroutine swiftest_orbel_xv2aeq(mu, rx, ry, rz, vx, vy, vz, a, e, q) !! author: David A. Minton !! !! Compute semimajor axis, eccentricity, and pericentric distance from relative Cartesian position and velocity @@ -700,25 +700,27 @@ pure elemental module subroutine swiftest_orbel_xv2aeq(mu, px, py, pz, vx, vy, v implicit none !! Arguments real(DP), intent(in) :: mu !! Gravitational constant - real(DP), intent(in) :: px,py,pz !! Position vector + real(DP), intent(in) :: rx,ry,rz !! Position vector real(DP), intent(in) :: vx,vy,vz !! Velocity vector real(DP), intent(out) :: a !! semimajor axis real(DP), intent(out) :: e !! eccentricity real(DP), intent(out) :: q !! periapsis ! Internals integer(I4B) :: iorbit_type - real(DP) :: r, v2, h2, energy, fac - real(DP), dimension(NDIM) :: hvec, x, v + real(DP) :: hx, hy, hz, r, v2, h2, energy, fac a = 0.0_DP e = 0.0_DP q = 0.0_DP - x = [px, py, pz] - v = [vx, vy, vz] - r = .mag.x(:) - v2 = dot_product(v(:), v(:)) - hvec(:) = x(:) .cross. v(:) - h2 = dot_product(hvec(:), hvec(:)) + + r = sqrt(rx*rx + ry*ry + rz*rz) + v2 = vx*vx + vy*vy + vz*vz + + hx = ry*vz - rz*vy + hy = rz*vx - rx*vz + hz = rx*vy - ry*vx + h2 = hx*hx + hy*hy + hz*hz + if (h2 == 0.0_DP) return energy = 0.5_DP * v2 - mu / r if (abs(energy * r / mu) < sqrt(TINYVALUE)) then @@ -755,7 +757,7 @@ pure elemental module subroutine swiftest_orbel_xv2aeq(mu, px, py, pz, vx, vy, v end subroutine swiftest_orbel_xv2aeq - pure module subroutine swiftest_orbel_xv2aqt(mu, px, py, pz, vx, vy, vz, a, q, capm, tperi) + pure module subroutine swiftest_orbel_xv2aqt(mu, rx, ry, rz, vx, vy, vz, a, q, capm, tperi) !! author: David A. Minton !! !! Compute semimajor axis, pericentric distance, mean anomaly, and time to nearest pericenter passage from @@ -767,7 +769,7 @@ pure module subroutine swiftest_orbel_xv2aqt(mu, px, py, pz, vx, vy, vz, a, q, c implicit none ! Arguments real(DP), intent(in) :: mu !! Gravitational constant - real(DP), intent(in) :: px,py,pz !! Position vector + real(DP), intent(in) :: rx,ry,rz !! Position vector real(DP), intent(in) :: vx,vy,vz !! Velocity vector real(DP), intent(out) :: a !! semimajor axis real(DP), intent(out) :: q !! periapsis @@ -775,21 +777,21 @@ pure module subroutine swiftest_orbel_xv2aqt(mu, px, py, pz, vx, vy, vz, a, q, c real(DP), intent(out) :: tperi !! time of pericenter passage ! Internals integer(I4B) :: iorbit_type - real(DP) :: r, v2, h2, rdotv, energy, fac, w, face, cape, e, tmpf, capf, mm - real(DP), dimension(NDIM) :: hvec, x, v + real(DP) :: hx, hy, hz, r, v2, h2, rdotv, energy, fac, w, face, cape, e, tmpf, capf, mm a = 0.0_DP q = 0.0_DP capm = 0.0_DP tperi = 0.0_DP - x = [px, py, pz] - v = [vx, vy, vz] - r = sqrt(dot_product(x(:), x(:))) - v2 = dot_product(v(:), v(:)) - hvec(:) = x(:) .cross. v(:) - h2 = dot_product(hvec(:), hvec(:)) + hx = ry*vz - rz*vy + hy = rz*vx - rx*vz + hz = rx*vy - ry*vx + h2 = hx*hx + hy*hy + hz*hz if (h2 == 0.0_DP) return - rdotv = dot_product(x(:), v(:)) + + r = sqrt(rx*rx + ry*ry + rz*rz) + v2 = vx*vx + vy*vy + vz*vz + rdotv = rx*vx + ry*vy + rz*vz energy = 0.5_DP * v2 - mu / r if (abs(energy * r / mu) < sqrt(TINYVALUE)) then iorbit_type = PARABOLA @@ -897,7 +899,7 @@ module subroutine swiftest_orbel_xv2el_vec(self, cb) end subroutine swiftest_orbel_xv2el_vec - pure module subroutine swiftest_orbel_xv2el(mu, px, py, pz, vx, vy, vz, a, e, inc, capom, omega, capm, varpi, lam, f, cape, capf) + pure module subroutine swiftest_orbel_xv2el(mu, rx, ry, rz, vx, vy, vz, a, e, inc, capom, omega, capm, varpi, lam, f, cape, capf) !! author: David A. Minton !! !! Compute osculating orbital elements from relative Cartesian position and velocity @@ -915,7 +917,7 @@ pure module subroutine swiftest_orbel_xv2el(mu, px, py, pz, vx, vy, vz, a, e, in implicit none ! Arguments real(DP), intent(in) :: mu !! Gravitational constant - real(DP), intent(in) :: px,py,pz !! Position vector + real(DP), intent(in) :: rx,ry,rz !! Position vector real(DP), intent(in) :: vx,vy,vz !! Velocity vector real(DP), intent(out) :: a !! semimajor axis real(DP), intent(out) :: e !! eccentricity @@ -930,8 +932,7 @@ pure module subroutine swiftest_orbel_xv2el(mu, px, py, pz, vx, vy, vz, a, e, in real(DP), intent(out) :: capf !! hyperbolic anomaly (hyperbolic orbits) ! Internals integer(I4B) :: iorbit_type - real(DP) :: r, v2, h2, h, rdotv, energy, fac, u, w, cw, sw, face, tmpf, sf, cf, rdot, h_over_r2 - real(DP), dimension(NDIM) :: hvec, x, v + real(DP) :: hx, hy, hz, r, v2, h2, h, rdotv, energy, fac, u, w, cw, sw, face, tmpf, sf, cf, rdot, h_over_r2 a = 0.0_DP e = 0.0_DP @@ -944,29 +945,37 @@ pure module subroutine swiftest_orbel_xv2el(mu, px, py, pz, vx, vy, vz, a, e, in f = 0.0_DP cape = 0.0_DP capf = 0.0_DP - x = [px, py, pz] - v = [vx, vy, vz] - r = .mag. x(:) - v2 = dot_product(v(:), v(:)) - hvec = x(:) .cross. v(:) - h2 = dot_product(hvec(:), hvec(:)) - h = .mag. hvec(:) + + hx = ry*vz - rz*vy + hy = rz*vx - rx*vz + hz = rx*vy - ry*vx + h2 = hx*hx + hy*hy +hz*hz + h = sqrt(h2) + if(hz>h) then ! Hal's fix + hz = h + hx = 0.0_DP + hy = 0.0_DP + endif if (h2 <= 10 * tiny(0.0_DP)) return - rdotv = dot_product(x(:), v(:)) + h = SQRT(h2) + + r = sqrt(rx*rx + ry*ry + rz*rz) + v2 = vx*vx + vy*vy + vz*vz + rdotv = rx*vx + ry*vy + rz*vz energy = 0.5_DP * v2 - mu / r - fac = hvec(3) / h + fac = hz / h if (fac < -1.0_DP) then inc = PI else if (fac < 1.0_DP) then inc = acos(fac) end if - fac = sqrt(hvec(1)**2 + hvec(2)**2) / h + fac = sqrt(hx**2 + hy**2) / h if (fac**2 < TINYVALUE) then - u = atan2(py, px) - if (hvec(3) < 0.0_DP) u = -u + u = atan2(ry, rx) + if (hz < 0.0_DP) u = -u else - capom = atan2(hvec(1), -hvec(2)) - u = atan2(pz / sin(inc), px * cos(capom) + py * sin(capom)) + capom = atan2(hx, -hy) + u = atan2(rz / sin(inc), rx * cos(capom) + ry * sin(capom)) end if if (capom < 0.0_DP) capom = capom + TWOPI if (u < 0.0_DP) u = u + TWOPI diff --git a/src/swiftest/swiftest_util.f90 b/src/swiftest/swiftest_util.f90 index fcf130f83..be98690c3 100644 --- a/src/swiftest/swiftest_util.f90 +++ b/src/swiftest/swiftest_util.f90 @@ -15,222 +15,101 @@ use fraggle contains - module subroutine swiftest_util_append_arr_char_string(arr, source, nold, nsrc, lsource_mask) + + module subroutine swiftest_util_append_arr_info(arr, source, nold, lsource_mask) !! author: David A. Minton !! - !! Append a single array of character string type onto another. If the destination array is not allocated, or is not big enough, this will allocate space for it. + !! Append a single array of particle information type onto another. If the destination array is not allocated, or is not big enough, this will allocate space for it. implicit none ! Arguments - character(len=STRMAX), dimension(:), allocatable, intent(inout) :: arr !! Destination array - character(len=STRMAX), dimension(:), allocatable, intent(in) :: source !! Array to append - integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively - logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: arr !! Destination array + type(swiftest_particle_info), dimension(:), allocatable, intent(in) :: source !! Array to append + integer(I4B), intent(in), optional :: nold !! Extent of original array. If passed, the source array will begin at arr(nold+1). Otherwise, the size of arr will be used. + logical, dimension(:), intent(in), optional :: lsource_mask !! Logical mask indicating which elements to append to ! Internals - integer(I4B) :: nnew - - if (.not. allocated(source)) return + integer(I4B) :: nnew, nsrc, nend_orig, i + integer(I4B), dimension(:), allocatable :: idx - nnew = count(lsource_mask(1:nsrc)) - if (nnew == 0) return + if (.not.allocated(source)) return - if (.not.allocated(arr)) then - allocate(arr(nold+nnew)) + if (present(lsource_mask)) then + nsrc = count(lsource_mask(:)) else - call swiftest_util_resize(arr, nold + nnew) + nsrc = size(source) end if - - arr(nold + 1:nold + nnew) = pack(source(1:nsrc), lsource_mask(1:nsrc)) - - return - end subroutine swiftest_util_append_arr_char_string - - - module subroutine swiftest_util_append_arr_DP(arr, source, nold, nsrc, lsource_mask) - !! author: David A. Minton - !! - !! Append a single array of double precision type onto another. If the destination array is not allocated, or is not big enough, this will allocate space for it. - implicit none - ! Arguments - real(DP), dimension(:), allocatable, intent(inout) :: arr !! Destination array - real(DP), dimension(:), allocatable, intent(in) :: source !! Array to append - integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively - logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to - ! Internals - integer(I4B) :: nnew - - if (.not. allocated(source)) return - - nnew = count(lsource_mask(1:nsrc)) - if (nnew == 0) return + if (nsrc == 0) return if (.not.allocated(arr)) then - allocate(arr(nold+nnew)) + nend_orig = 0 + allocate(arr(nsrc)) else - call swiftest_util_resize(arr, nold + nnew) + if (present(nold)) then + nend_orig = nold + else + nend_orig = size(arr) + end if + call util_resize(arr, nend_orig + nsrc) end if + nnew = nend_orig + nsrc - arr(nold + 1:nold + nnew) = pack(source(1:nsrc), lsource_mask(1:nsrc)) - - return - end subroutine swiftest_util_append_arr_DP - - - module subroutine swiftest_util_append_arr_DPvec(arr, source, nold, nsrc, lsource_mask) - !! author: David A. Minton - !! - !! Append a single array of double precision vector type of size (NDIM, n) onto another. If the destination array is not allocated, or is not big enough, this will allocate space for it. - implicit none - ! Arguments - real(DP), dimension(:,:), allocatable, intent(inout) :: arr !! Destination array - real(DP), dimension(:,:), allocatable, intent(in) :: source !! Array to append - integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively - logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to - ! Internals - integer(I4B) :: nnew - - if (.not. allocated(source)) return - - nnew = count(lsource_mask(1:nsrc)) - if (nnew == 0) return - - if (.not.allocated(arr)) then - allocate(arr(NDIM,nold+nnew)) + allocate(idx(nsrc)) + if (present(lsource_mask)) then + idx = pack([(i, i = 1, size(lsource_mask))], lsource_mask(:)) else - call swiftest_util_resize(arr, nold + nnew) - end if + idx = [(i, i = 1,nsrc)] + end if - arr(1, nold + 1:nold + nnew) = pack(source(1,1:nsrc), lsource_mask(1:nsrc)) - arr(2, nold + 1:nold + nnew) = pack(source(2,1:nsrc), lsource_mask(1:nsrc)) - arr(3, nold + 1:nold + nnew) = pack(source(3,1:nsrc), lsource_mask(1:nsrc)) + call swiftest_util_copy_particle_info_arr(source(:), arr(nend_orig+1:nnew), idx) return - end subroutine swiftest_util_append_arr_DPvec + end subroutine swiftest_util_append_arr_info - module subroutine swiftest_util_append_arr_I4B(arr, source, nold, nsrc, lsource_mask) + module subroutine swiftest_util_append_arr_kin(arr, source, nold, lsource_mask) !! author: David A. Minton !! - !! Append a single array of integer(I4B) onto another. If the destination array is not allocated, or is not big enough, this will allocate space for it. + !! Append a single array of kinship type onto another. If the destination array is not allocated, or is not big enough, this will allocate space for it. implicit none ! Arguments - integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), allocatable, intent(in) :: source !! Array to append - integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively - logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + type(swiftest_kinship), dimension(:), allocatable, intent(inout) :: arr !! Destination array + type(swiftest_kinship), dimension(:), allocatable, intent(in) :: source !! Array to append + integer(I4B), intent(in), optional :: nold !! Extent of original array. If passed, the source array will begin at arr(nold+1). Otherwise, the size of arr will be used. + logical, dimension(:), intent(in), optional :: lsource_mask !! Logical mask indicating which elements to append to ! Internals - integer(I4B) :: nnew - - if (.not. allocated(source)) return + integer(I4B) :: nnew, nsrc, nend_orig - nnew = count(lsource_mask(1:nsrc)) - if (nnew == 0) return + if (.not.allocated(source)) return - if (.not.allocated(arr)) then - allocate(arr(nold+nnew)) + if (present(lsource_mask)) then + nsrc = count(lsource_mask(:)) else - call swiftest_util_resize(arr, nold + nnew) + nsrc = size(source) end if - - arr(nold + 1:nold + nnew) = pack(source(1:nsrc), lsource_mask(1:nsrc)) - - return - end subroutine swiftest_util_append_arr_I4B - - - module subroutine swiftest_util_append_arr_info(arr, source, nold, nsrc, lsource_mask) - !! author: David A. Minton - !! - !! Append a single array of particle information type onto another. If the destination array is not allocated, or is not big enough, this will allocate space for it. - implicit none - ! Arguments - type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: arr !! Destination array - type(swiftest_particle_info), dimension(:), allocatable, intent(in) :: source !! Array to append - integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively - logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to - ! Internals - integer(I4B) :: nnew, i - integer(I4B), dimension(:), allocatable :: idx - - if (.not. allocated(source)) return - - nnew = count(lsource_mask(1:nsrc)) - if (nnew == 0) return + if (nsrc == 0) return if (.not.allocated(arr)) then - allocate(arr(nold+nnew)) + nend_orig = 0 + allocate(arr(nsrc)) else - call swiftest_util_resize(arr, nold + nnew) + if (present(nold)) then + nend_orig = nold + else + nend_orig = size(arr) + end if + call util_resize(arr, nend_orig + nsrc) end if + nnew = nend_orig + nsrc - allocate(idx(nnew)) - - idx = pack([(i, i = 1, nsrc)], lsource_mask(1:nsrc)) - - call swiftest_util_copy_particle_info_arr(source(1:nsrc), arr(nold+1:nold+nnew), idx) - - return - end subroutine swiftest_util_append_arr_info - - - module subroutine swiftest_util_append_arr_kin(arr, source, nold, nsrc, lsource_mask) - !! author: David A. Minton - !! - !! Append a single array of kinship type onto another. If the destination array is not allocated, or is not big enough, this will allocate space for it. - implicit none - ! Arguments - type(swiftest_kinship), dimension(:), allocatable, intent(inout) :: arr !! Destination array - type(swiftest_kinship), dimension(:), allocatable, intent(in) :: source !! Array to append - integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively - logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to - ! Internals - integer(I4B) :: nnew - - if (.not. allocated(source)) return - - nnew = count(lsource_mask(1:nsrc)) - if (nnew == 0) return - - if (.not.allocated(arr)) then - allocate(arr(nold+nnew)) + if (present(lsource_mask)) then + arr(nend_orig + 1:nnew) = pack(source(1:nsrc), lsource_mask(1:nsrc)) else - call swiftest_util_resize(arr, nold + nnew) + arr(nend_orig + 1:nnew) = source(1:nsrc) end if - arr(nold + 1:nold + nnew) = pack(source(1:nsrc), lsource_mask(1:nsrc)) - return end subroutine swiftest_util_append_arr_kin - module subroutine swiftest_util_append_arr_logical(arr, source, nold, nsrc, lsource_mask) - !! author: David A. Minton - !! - !! Append a single array of logical type onto another. If the destination array is not allocated, or is not big enough, this will allocate space for it. - implicit none - ! Arguments - logical, dimension(:), allocatable, intent(inout) :: arr !! Destination array - logical, dimension(:), allocatable, intent(in) :: source !! Array to append - integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively - logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to - ! Internals - integer(I4B) :: nnew - - if (.not. allocated(source)) return - - nnew = count(lsource_mask(1:nsrc)) - if (nnew == 0) return - - if (.not.allocated(arr)) then - allocate(arr(nold+nnew)) - else - call swiftest_util_resize(arr, nold + nnew) - end if - - arr(nold + 1:nold + nnew) = pack(source(1:nsrc), lsource_mask(1:nsrc)) - - return - end subroutine swiftest_util_append_arr_logical - module subroutine swiftest_util_append_body(self, source, lsource_mask) !! author: David A. Minton @@ -243,40 +122,36 @@ module subroutine swiftest_util_append_body(self, source, lsource_mask) class(swiftest_body), intent(in) :: source !! Source object to append logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to ! Internals - integer(I4B) :: nold, nsrc, nnew - - nold = self%nbody - nsrc = source%nbody - nnew = count(lsource_mask(1:nsrc)) - - call swiftest_util_append(self%id, source%id, nold, nsrc, lsource_mask) - call swiftest_util_append(self%info, source%info, nold, nsrc, lsource_mask) - call swiftest_util_append(self%lmask, source%lmask, nold, nsrc, lsource_mask) - call swiftest_util_append(self%status, source%status, nold, nsrc, lsource_mask) - call swiftest_util_append(self%ldiscard, source%ldiscard, nold, nsrc, lsource_mask) - call swiftest_util_append(self%lencounter, source%lencounter, nold, nsrc, lsource_mask) - call swiftest_util_append(self%lcollision, source%lcollision, nold, nsrc, lsource_mask) - call swiftest_util_append(self%mu, source%mu, nold, nsrc, lsource_mask) - call swiftest_util_append(self%rh, source%rh, nold, nsrc, lsource_mask) - call swiftest_util_append(self%vh, source%vh, nold, nsrc, lsource_mask) - call swiftest_util_append(self%rb, source%rb, nold, nsrc, lsource_mask) - call swiftest_util_append(self%vb, source%vb, nold, nsrc, lsource_mask) - call swiftest_util_append(self%ah, source%ah, nold, nsrc, lsource_mask) - call swiftest_util_append(self%aobl, source%aobl, nold, nsrc, lsource_mask) - call swiftest_util_append(self%atide, source%atide, nold, nsrc, lsource_mask) - call swiftest_util_append(self%agr, source%agr, nold, nsrc, lsource_mask) - call swiftest_util_append(self%ir3h, source%ir3h, nold, nsrc, lsource_mask) - call swiftest_util_append(self%isperi, source%isperi, nold, nsrc, lsource_mask) - call swiftest_util_append(self%peri, source%peri, nold, nsrc, lsource_mask) - call swiftest_util_append(self%atp, source%atp, nold, nsrc, lsource_mask) - call swiftest_util_append(self%a, source%a, nold, nsrc, lsource_mask) - call swiftest_util_append(self%e, source%e, nold, nsrc, lsource_mask) - call swiftest_util_append(self%inc, source%inc, nold, nsrc, lsource_mask) - call swiftest_util_append(self%capom, source%capom, nold, nsrc, lsource_mask) - call swiftest_util_append(self%omega, source%omega, nold, nsrc, lsource_mask) - call swiftest_util_append(self%capm, source%capm, nold, nsrc, lsource_mask) - - self%nbody = nold + nnew + + + call util_append(self%id, source%id, lsource_mask=lsource_mask) + call util_append(self%info, source%info, lsource_mask=lsource_mask) + call util_append(self%lmask, source%lmask, lsource_mask=lsource_mask) + call util_append(self%status, source%status, lsource_mask=lsource_mask) + call util_append(self%ldiscard, source%ldiscard, lsource_mask=lsource_mask) + call util_append(self%lencounter, source%lencounter, lsource_mask=lsource_mask) + call util_append(self%lcollision, source%lcollision, lsource_mask=lsource_mask) + call util_append(self%mu, source%mu, lsource_mask=lsource_mask) + call util_append(self%rh, source%rh, lsource_mask=lsource_mask) + call util_append(self%vh, source%vh, lsource_mask=lsource_mask) + call util_append(self%rb, source%rb, lsource_mask=lsource_mask) + call util_append(self%vb, source%vb, lsource_mask=lsource_mask) + call util_append(self%ah, source%ah, lsource_mask=lsource_mask) + call util_append(self%aobl, source%aobl, lsource_mask=lsource_mask) + call util_append(self%atide, source%atide, lsource_mask=lsource_mask) + call util_append(self%agr, source%agr, lsource_mask=lsource_mask) + call util_append(self%ir3h, source%ir3h, lsource_mask=lsource_mask) + call util_append(self%isperi, source%isperi, lsource_mask=lsource_mask) + call util_append(self%peri, source%peri, lsource_mask=lsource_mask) + call util_append(self%atp, source%atp, lsource_mask=lsource_mask) + call util_append(self%a, source%a, lsource_mask=lsource_mask) + call util_append(self%e, source%e, lsource_mask=lsource_mask) + call util_append(self%inc, source%inc, lsource_mask=lsource_mask) + call util_append(self%capom, source%capom, lsource_mask=lsource_mask) + call util_append(self%omega, source%omega, lsource_mask=lsource_mask) + call util_append(self%capm, source%capm, lsource_mask=lsource_mask) + + self%nbody = self%nbody + count(lsource_mask(:)) return end subroutine swiftest_util_append_body @@ -295,30 +170,28 @@ module subroutine swiftest_util_append_pl(self, source, lsource_mask) select type(source) class is (swiftest_pl) - associate(nold => self%nbody, nsrc => source%nbody) - call swiftest_util_append(self%mass, source%mass, nold, nsrc, lsource_mask) - call swiftest_util_append(self%Gmass, source%Gmass, nold, nsrc, lsource_mask) - call swiftest_util_append(self%rhill, source%rhill, nold, nsrc, lsource_mask) - call swiftest_util_append(self%renc, source%renc, nold, nsrc, lsource_mask) - call swiftest_util_append(self%radius, source%radius, nold, nsrc, lsource_mask) - call swiftest_util_append(self%density, source%density, nold, nsrc, lsource_mask) - call swiftest_util_append(self%rbeg, source%rbeg, nold, nsrc, lsource_mask) - call swiftest_util_append(self%rend, source%rend, nold, nsrc, lsource_mask) - call swiftest_util_append(self%vbeg, source%vbeg, nold, nsrc, lsource_mask) - call swiftest_util_append(self%Ip, source%Ip, nold, nsrc, lsource_mask) - call swiftest_util_append(self%rot, source%rot, nold, nsrc, lsource_mask) - call swiftest_util_append(self%k2, source%k2, nold, nsrc, lsource_mask) - call swiftest_util_append(self%Q, source%Q, nold, nsrc, lsource_mask) - call swiftest_util_append(self%tlag, source%tlag, nold, nsrc, lsource_mask) - call swiftest_util_append(self%kin, source%kin, nold, nsrc, lsource_mask) - call swiftest_util_append(self%lmtiny, source%lmtiny, nold, nsrc, lsource_mask) - call swiftest_util_append(self%nplenc, source%nplenc, nold, nsrc, lsource_mask) - call swiftest_util_append(self%ntpenc, source%ntpenc, nold, nsrc, lsource_mask) - - if (allocated(self%k_plpl)) deallocate(self%k_plpl) - - call swiftest_util_append_body(self, source, lsource_mask) - end associate + call util_append(self%mass, source%mass, lsource_mask=lsource_mask) + call util_append(self%Gmass, source%Gmass, lsource_mask=lsource_mask) + call util_append(self%rhill, source%rhill, lsource_mask=lsource_mask) + call util_append(self%renc, source%renc, lsource_mask=lsource_mask) + call util_append(self%radius, source%radius, lsource_mask=lsource_mask) + call util_append(self%density, source%density, lsource_mask=lsource_mask) + call util_append(self%rbeg, source%rbeg, lsource_mask=lsource_mask) + call util_append(self%rend, source%rend, lsource_mask=lsource_mask) + call util_append(self%vbeg, source%vbeg, lsource_mask=lsource_mask) + call util_append(self%Ip, source%Ip, lsource_mask=lsource_mask) + call util_append(self%rot, source%rot, lsource_mask=lsource_mask) + call util_append(self%k2, source%k2, lsource_mask=lsource_mask) + call util_append(self%Q, source%Q, lsource_mask=lsource_mask) + call util_append(self%tlag, source%tlag, lsource_mask=lsource_mask) + call util_append(self%kin, source%kin, lsource_mask=lsource_mask) + call util_append(self%lmtiny, source%lmtiny, lsource_mask=lsource_mask) + call util_append(self%nplenc, source%nplenc, lsource_mask=lsource_mask) + call util_append(self%ntpenc, source%ntpenc, lsource_mask=lsource_mask) + + if (allocated(self%k_plpl)) deallocate(self%k_plpl) + + call swiftest_util_append_body(self, source, lsource_mask) class default write(*,*) "Invalid object passed to the append method. Source must be of class swiftest_pl or its descendents" call base_util_exit(FAILURE) @@ -341,11 +214,9 @@ module subroutine swiftest_util_append_tp(self, source, lsource_mask) select type(source) class is (swiftest_tp) - associate(nold => self%nbody, nsrc => source%nbody) - call swiftest_util_append(self%nplenc, source%nplenc, nold, nsrc, lsource_mask) + call util_append(self%nplenc, source%nplenc, lsource_mask=lsource_mask) - call swiftest_util_append_body(self, source, lsource_mask) - end associate + call swiftest_util_append_body(self, source, lsource_mask) class default write(*,*) "Invalid object passed to the append method. Source must be of class swiftest_tp or its descendents" call base_util_exit(FAILURE) @@ -727,7 +598,8 @@ module subroutine swiftest_util_dealloc_body(self) class(swiftest_body), intent(inout) :: self self%lfirst = .true. - + self%nbody = 0 + if (allocated(self%id)) deallocate(self%id) if (allocated(self%info)) deallocate(self%info) if (allocated(self%status)) deallocate(self%status) if (allocated(self%lmask)) deallocate(self%lmask) @@ -754,8 +626,6 @@ module subroutine swiftest_util_dealloc_body(self) if (allocated(self%omega)) deallocate(self%omega) if (allocated(self%capm)) deallocate(self%capm) - call base_util_dealloc_multibody(self) - return end subroutine swiftest_util_dealloc_body @@ -897,7 +767,6 @@ module subroutine swiftest_util_dealloc_system(self) if (allocated(self%collider)) deallocate(self%collider) if (allocated(self%encounter_history)) deallocate(self%encounter_history) if (allocated(self%collision_history)) deallocate(self%collision_history) - if (allocated(self%system_history)) deallocate(self%system_history) self%t = -1.0_DP self%GMtot = 0.0_DP @@ -960,89 +829,6 @@ module subroutine swiftest_util_dealloc_tp(self) end subroutine swiftest_util_dealloc_tp - module subroutine swiftest_util_fill_arr_char_string(keeps, inserts, lfill_list) - !! author: David A. Minton - !! - !! Performs a fill operation on a single array of type character strings - !! This is the inverse of a spill operation - implicit none - ! Arguments - character(len=STRMAX), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - character(len=STRMAX), dimension(:), allocatable, intent(in) :: inserts !! Array of values to insert into keep - logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - - if (.not.allocated(keeps) .or. .not.allocated(inserts)) return - - keeps(:) = unpack(keeps(:), .not.lfill_list(:), keeps(:)) - keeps(:) = unpack(inserts(:), lfill_list(:), keeps(:)) - - return - end subroutine swiftest_util_fill_arr_char_string - - - module subroutine swiftest_util_fill_arr_DP(keeps, inserts, lfill_list) - !! author: David A. Minton - !! - !! Performs a fill operation on a single array of type DP - !! This is the inverse of a spill operation - implicit none - ! Arguments - real(DP), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - real(DP), dimension(:), allocatable, intent(in) :: inserts !! Array of values to insert into keep - logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - - if (.not.allocated(keeps) .or. .not.allocated(inserts)) return - - keeps(:) = unpack(keeps(:), .not.lfill_list(:), keeps(:)) - keeps(:) = unpack(inserts(:), lfill_list(:), keeps(:)) - - return - end subroutine swiftest_util_fill_arr_DP - - - module subroutine swiftest_util_fill_arr_DPvec(keeps, inserts, lfill_list) - !! author: David A. Minton - !! - !! Performs a fill operation on a single array of DP vectors with shape (NDIM, n) - !! This is the inverse of a spill operation - implicit none - ! Arguments - real(DP), dimension(:,:), allocatable, intent(inout) :: keeps !! Array of values to keep - real(DP), dimension(:,:), allocatable, intent(in) :: inserts !! Array of values to insert into keep - logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - ! Internals - integer(I4B) :: i - - if (.not.allocated(keeps) .or. .not.allocated(inserts)) return - - do i = 1, NDIM - keeps(i,:) = unpack(keeps(i,:), .not.lfill_list(:), keeps(i,:)) - keeps(i,:) = unpack(inserts(i,:), lfill_list(:), keeps(i,:)) - end do - - return - end subroutine swiftest_util_fill_arr_DPvec - - - module subroutine swiftest_util_fill_arr_I4B(keeps, inserts, lfill_list) - !! author: David A. Minton - !! - !! Performs a fill operation on a single array of type I4B - !! This is the inverse of a spill operation - implicit none - ! Arguments - integer(I4B), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - integer(I4B), dimension(:), allocatable, intent(in) :: inserts !! Array of values to insert into keep - logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - - if (.not.allocated(keeps) .or. .not.allocated(inserts)) return - - keeps(:) = unpack(keeps(:), .not.lfill_list(:), keeps(:)) - keeps(:) = unpack(inserts(:), lfill_list(:), keeps(:)) - - return - end subroutine swiftest_util_fill_arr_I4B - module subroutine swiftest_util_fill_arr_info(keeps, inserts, lfill_list) !! author: David A. Minton @@ -1072,26 +858,6 @@ module subroutine swiftest_util_fill_arr_info(keeps, inserts, lfill_list) end subroutine swiftest_util_fill_arr_info - module subroutine swiftest_util_fill_arr_logical(keeps, inserts, lfill_list) - !! author: David A. Minton - !! - !! Performs a fill operation on a single array of logicals - !! This is the inverse of a spill operation - implicit none - ! Arguments - logical, dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - logical, dimension(:), allocatable, intent(in) :: inserts !! Array of values to insert into keep - logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - - if (.not.allocated(keeps) .or. .not.allocated(inserts)) return - - keeps(:) = unpack(keeps(:), .not.lfill_list(:), keeps(:)) - keeps(:) = unpack(inserts(:), lfill_list(:), keeps(:)) - - return - end subroutine swiftest_util_fill_arr_logical - - module subroutine swiftest_util_fill_arr_kin(keeps, inserts, lfill_list) !! author: David A. Minton !! @@ -1126,32 +892,32 @@ module subroutine swiftest_util_fill_body(self, inserts, lfill_list) ! For each component, pack the discarded bodies into the discard object and do the inverse with the keeps !> Fill all the common components associate(keeps => self) - call swiftest_util_fill(keeps%id, inserts%id, lfill_list) - call swiftest_util_fill(keeps%info, inserts%info, lfill_list) - call swiftest_util_fill(keeps%lmask, inserts%lmask, lfill_list) - call swiftest_util_fill(keeps%status, inserts%status, lfill_list) - call swiftest_util_fill(keeps%ldiscard, inserts%ldiscard, lfill_list) - call swiftest_util_fill(keeps%lcollision, inserts%lcollision, lfill_list) - call swiftest_util_fill(keeps%lencounter, inserts%lencounter, lfill_list) - call swiftest_util_fill(keeps%mu, inserts%mu, lfill_list) - call swiftest_util_fill(keeps%rh, inserts%rh, lfill_list) - call swiftest_util_fill(keeps%vh, inserts%vh, lfill_list) - call swiftest_util_fill(keeps%rb, inserts%rb, lfill_list) - call swiftest_util_fill(keeps%vb, inserts%vb, lfill_list) - call swiftest_util_fill(keeps%ah, inserts%ah, lfill_list) - call swiftest_util_fill(keeps%aobl, inserts%aobl, lfill_list) - call swiftest_util_fill(keeps%agr, inserts%agr, lfill_list) - call swiftest_util_fill(keeps%atide, inserts%atide, lfill_list) - call swiftest_util_fill(keeps%ir3h, inserts%ir3h, lfill_list) - call swiftest_util_fill(keeps%isperi, inserts%isperi, lfill_list) - call swiftest_util_fill(keeps%peri, inserts%peri, lfill_list) - call swiftest_util_fill(keeps%atp, inserts%atp, lfill_list) - call swiftest_util_fill(keeps%a, inserts%a, lfill_list) - call swiftest_util_fill(keeps%e, inserts%e, lfill_list) - call swiftest_util_fill(keeps%inc, inserts%inc, lfill_list) - call swiftest_util_fill(keeps%capom, inserts%capom, lfill_list) - call swiftest_util_fill(keeps%omega, inserts%omega, lfill_list) - call swiftest_util_fill(keeps%capm, inserts%capm, lfill_list) + call util_fill(keeps%id, inserts%id, lfill_list) + call util_fill(keeps%info, inserts%info, lfill_list) + call util_fill(keeps%lmask, inserts%lmask, lfill_list) + call util_fill(keeps%status, inserts%status, lfill_list) + call util_fill(keeps%ldiscard, inserts%ldiscard, lfill_list) + call util_fill(keeps%lcollision, inserts%lcollision, lfill_list) + call util_fill(keeps%lencounter, inserts%lencounter, lfill_list) + call util_fill(keeps%mu, inserts%mu, lfill_list) + call util_fill(keeps%rh, inserts%rh, lfill_list) + call util_fill(keeps%vh, inserts%vh, lfill_list) + call util_fill(keeps%rb, inserts%rb, lfill_list) + call util_fill(keeps%vb, inserts%vb, lfill_list) + call util_fill(keeps%ah, inserts%ah, lfill_list) + call util_fill(keeps%aobl, inserts%aobl, lfill_list) + call util_fill(keeps%agr, inserts%agr, lfill_list) + call util_fill(keeps%atide, inserts%atide, lfill_list) + call util_fill(keeps%ir3h, inserts%ir3h, lfill_list) + call util_fill(keeps%isperi, inserts%isperi, lfill_list) + call util_fill(keeps%peri, inserts%peri, lfill_list) + call util_fill(keeps%atp, inserts%atp, lfill_list) + call util_fill(keeps%a, inserts%a, lfill_list) + call util_fill(keeps%e, inserts%e, lfill_list) + call util_fill(keeps%inc, inserts%inc, lfill_list) + call util_fill(keeps%capom, inserts%capom, lfill_list) + call util_fill(keeps%omega, inserts%omega, lfill_list) + call util_fill(keeps%capm, inserts%capm, lfill_list) ! This is the base class, so will be the last to be called in the cascade. keeps%nbody = size(keeps%id(:)) @@ -1177,23 +943,23 @@ module subroutine swiftest_util_fill_pl(self, inserts, lfill_list) select type (inserts) ! The standard requires us to select the type of both arguments in order to access all the components class is (swiftest_pl) !> Fill components specific to the massive body class - call swiftest_util_fill(keeps%mass, inserts%mass, lfill_list) - call swiftest_util_fill(keeps%Gmass, inserts%Gmass, lfill_list) - call swiftest_util_fill(keeps%rhill, inserts%rhill, lfill_list) - call swiftest_util_fill(keeps%renc, inserts%renc, lfill_list) - call swiftest_util_fill(keeps%radius, inserts%radius, lfill_list) - call swiftest_util_fill(keeps%density, inserts%density, lfill_list) - call swiftest_util_fill(keeps%rbeg, inserts%rbeg, lfill_list) - call swiftest_util_fill(keeps%rend, inserts%rend, lfill_list) - call swiftest_util_fill(keeps%vbeg, inserts%vbeg, lfill_list) - call swiftest_util_fill(keeps%Ip, inserts%Ip, lfill_list) - call swiftest_util_fill(keeps%rot, inserts%rot, lfill_list) - call swiftest_util_fill(keeps%k2, inserts%k2, lfill_list) - call swiftest_util_fill(keeps%Q, inserts%Q, lfill_list) - call swiftest_util_fill(keeps%tlag, inserts%tlag, lfill_list) - call swiftest_util_fill(keeps%kin, inserts%kin, lfill_list) - call swiftest_util_fill(keeps%nplenc, inserts%nplenc, lfill_list) - call swiftest_util_fill(keeps%ntpenc, inserts%ntpenc, lfill_list) + call util_fill(keeps%mass, inserts%mass, lfill_list) + call util_fill(keeps%Gmass, inserts%Gmass, lfill_list) + call util_fill(keeps%rhill, inserts%rhill, lfill_list) + call util_fill(keeps%renc, inserts%renc, lfill_list) + call util_fill(keeps%radius, inserts%radius, lfill_list) + call util_fill(keeps%density, inserts%density, lfill_list) + call util_fill(keeps%rbeg, inserts%rbeg, lfill_list) + call util_fill(keeps%rend, inserts%rend, lfill_list) + call util_fill(keeps%vbeg, inserts%vbeg, lfill_list) + call util_fill(keeps%Ip, inserts%Ip, lfill_list) + call util_fill(keeps%rot, inserts%rot, lfill_list) + call util_fill(keeps%k2, inserts%k2, lfill_list) + call util_fill(keeps%Q, inserts%Q, lfill_list) + call util_fill(keeps%tlag, inserts%tlag, lfill_list) + call util_fill(keeps%kin, inserts%kin, lfill_list) + call util_fill(keeps%nplenc, inserts%nplenc, lfill_list) + call util_fill(keeps%ntpenc, inserts%ntpenc, lfill_list) if (allocated(keeps%k_plpl)) deallocate(keeps%k_plpl) @@ -1222,7 +988,7 @@ module subroutine swiftest_util_fill_tp(self, inserts, lfill_list) select type(inserts) class is (swiftest_tp) !> Spill components specific to the test particle class - call swiftest_util_fill(keeps%nplenc, inserts%nplenc, lfill_list) + call util_fill(keeps%nplenc, inserts%nplenc, lfill_list) call swiftest_util_fill_body(keeps, inserts, lfill_list) class default @@ -1708,10 +1474,10 @@ module subroutine swiftest_util_index_map_storage(self) call swiftest_util_get_vals_storage(self, idvals, tvals) - call swiftest_util_unique(idvals,self%idvals,self%idmap) + call util_unique(idvals,self%idvals,self%idmap) self%nid = size(self%idvals) - call swiftest_util_unique(tvals,self%tvals,self%tmap) + call util_unique(tvals,self%tvals,self%tmap) self%nt = size(self%tvals) return @@ -1752,8 +1518,9 @@ module subroutine swiftest_util_peri(n,m, r, v, atp, q, isperi) integer(I4B) :: i real(DP), dimension(n) :: e !! Temporary, just to make use of the xv2aeq subroutine real(DP) :: vdotr + character(len=NAMELEN) :: message - do concurrent(i = 1:n) + do i = 1,n vdotr = dot_product(r(:,i),v(:,i)) if (isperi(i) == -1) then if (vdotr >= 0.0) then @@ -2046,16 +1813,16 @@ module subroutine swiftest_util_reset_kinship_pl(self, idx) end subroutine swiftest_util_reset_kinship_pl - module subroutine swiftest_util_resize_arr_char_string(arr, nnew) + module subroutine swiftest_util_resize_arr_info(arr, nnew) !! author: David A. Minton !! - !! Resizes an array component of type character string. nnew = 0 will deallocate. + !! Resizes an array component of type character string. Array will only be resized if has previously been allocated. Passing nnew = 0 will deallocate. implicit none ! Arguments - character(len=STRMAX), dimension(:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size + type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: arr !! Array to resize + integer(I4B), intent(in) :: nnew !! New size ! Internals - character(len=STRMAX), dimension(:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated + type(swiftest_particle_info), dimension(:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated integer(I4B) :: nold !! Old size if (nnew < 0) return @@ -2074,34 +1841,29 @@ module subroutine swiftest_util_resize_arr_char_string(arr, nnew) if (nnew == nold) return allocate(tmp(nnew)) - if (nold > 0) then - if (nnew > nold) then - tmp(1:nold) = arr(1:nold) - tmp(nold+1:nnew) = "" - else - tmp(1:nnew) = arr(1:nnew) - end if + if (nnew > nold) then + call swiftest_util_copy_particle_info_arr(arr(1:nold), tmp(1:nold)) else - tmp(1:nnew) = "" + call swiftest_util_copy_particle_info_arr(arr(1:nnew), tmp(1:nnew)) end if + call move_alloc(tmp, arr) return - end subroutine swiftest_util_resize_arr_char_string - + end subroutine swiftest_util_resize_arr_info - module subroutine swiftest_util_resize_arr_DP(arr, nnew) + + module subroutine swiftest_util_resize_arr_kin(arr, nnew) !! author: David A. Minton !! - !! Resizes an array component of double precision type. Passing nnew = 0 will deallocate. + !! Resizes an array component of type character string. Array will only be resized if has previously been allocated. Passing nnew = 0 will deallocate. implicit none ! Arguments - real(DP), dimension(:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size + type(swiftest_kinship), dimension(:), allocatable, intent(inout) :: arr !! Array to resize + integer(I4B), intent(in) :: nnew !! New size ! Internals - real(DP), dimension(:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated + type(swiftest_kinship), dimension(:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated integer(I4B) :: nold !! Old size - real(DP), parameter :: init_val = 0.0_DP if (nnew < 0) return @@ -2116,324 +1878,98 @@ module subroutine swiftest_util_resize_arr_DP(arr, nnew) nold = 0 end if - if (nnew == nold) return - allocate(tmp(nnew)) - if (nold > 0) then - if (nnew > nold) then - tmp(1:nold) = arr(1:nold) - tmp(nold+1:nnew) = init_val - else - tmp(1:nnew) = arr(1:nnew) - end if + if (nnew > nold) then + tmp(1:nold) = arr(1:nold) else - tmp(1:nnew) = init_val + tmp(1:nnew) = arr(1:nnew) end if call move_alloc(tmp, arr) return - end subroutine swiftest_util_resize_arr_DP + end subroutine swiftest_util_resize_arr_kin - module subroutine swiftest_util_resize_arr_DPvec(arr, nnew) + module subroutine swiftest_util_resize_body(self, nnew) !! author: David A. Minton !! - !! Resizes an array component of double precision vectors of size (NDIM, n). Passing nnew = 0 will deallocate. + !! Checks the current size of a Swiftest body against the requested size and resizes it if it is too small. implicit none ! Arguments - real(DP), dimension(:,:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size - ! Internals - real(DP), dimension(:,:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated - integer(I4B) :: nold !! Old size - real(DP), dimension(NDIM), parameter :: init_val = 0.0_DP - integer(I4B) :: i - - if (nnew < 0) return - - if (nnew == 0) then - if (allocated(arr)) deallocate(arr) - return - end if - - if (allocated(arr)) then - nold = size(arr, dim=2) - else - nold = 0 - end if - - if (nnew == nold) return - - allocate(tmp(NDIM, nnew)) - if (nold > 0) then - if (nnew > nold) then - tmp(:,1:nold) = arr(:,1:nold) - do i = nold+1, nnew - tmp(:,i) = init_val(:) - end do - else - tmp(:,1:nnew) = arr(:,1:nnew) - end if - else - do i = 1, nnew - tmp(:, i) = init_val(:) - end do - end if - call move_alloc(tmp, arr) + class(swiftest_body), intent(inout) :: self !! Swiftest body object + integer(I4B), intent(in) :: nnew !! New size neded - return + call util_resize(self%info, nnew) + call util_resize(self%id, nnew) + call util_resize(self%status, nnew) + call util_resize(self%lcollision, nnew) + call util_resize(self%lencounter, nnew) + call util_resize(self%ldiscard, nnew) + call util_resize(self%lmask, nnew) + call util_resize(self%mu, nnew) + call util_resize(self%rh, nnew) + call util_resize(self%vh, nnew) + call util_resize(self%rb, nnew) + call util_resize(self%vb, nnew) + call util_resize(self%ah, nnew) + call util_resize(self%aobl, nnew) + call util_resize(self%atide, nnew) + call util_resize(self%agr, nnew) + call util_resize(self%ir3h, nnew) + call util_resize(self%a, nnew) + call util_resize(self%e, nnew) + call util_resize(self%inc, nnew) + call util_resize(self%capom, nnew) + call util_resize(self%omega, nnew) + call util_resize(self%capm, nnew) + self%nbody = count(self%status(1:nnew) /= INACTIVE) return - end subroutine swiftest_util_resize_arr_DPvec + end subroutine swiftest_util_resize_body - module subroutine swiftest_util_resize_arr_I4B(arr, nnew) + module subroutine swiftest_util_resize_pl(self, nnew) !! author: David A. Minton !! - !! Resizes an array component of integer type. Passing nnew = 0 will deallocate. + !! Checks the current size of a Swiftest massive body against the requested size and resizes it if it is too small. implicit none ! Arguments - integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size - ! Internals - integer(I4B), dimension(:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated - integer(I4B) :: nold !! Old size - integer(I4B), parameter :: init_val = -1 + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + integer(I4B), intent(in) :: nnew !! New size neded - if (nnew < 0) return + call swiftest_util_resize_body(self, nnew) - if (nnew == 0) then - if (allocated(arr)) deallocate(arr) - return - end if - - if (allocated(arr)) then - nold = size(arr) - else - nold = 0 - end if + call util_resize(self%mass, nnew) + call util_resize(self%Gmass, nnew) + call util_resize(self%rhill, nnew) + call util_resize(self%renc, nnew) + call util_resize(self%radius, nnew) + call util_resize(self%rbeg, nnew) + call util_resize(self%rend, nnew) + call util_resize(self%vbeg, nnew) + call util_resize(self%density, nnew) + call util_resize(self%Ip, nnew) + call util_resize(self%rot, nnew) + call util_resize(self%k2, nnew) + call util_resize(self%Q, nnew) + call util_resize(self%tlag, nnew) + call util_resize(self%kin, nnew) + call util_resize(self%lmtiny, nnew) + call util_resize(self%nplenc, nnew) + call util_resize(self%ntpenc, nnew) - if (nnew == nold) return - - allocate(tmp(nnew)) - if (nold > 0) then - if (nnew > nold) then - tmp(1:nold) = arr(1:nold) - tmp(nold+1:nnew) = init_val - else - tmp(1:nnew) = arr(1:nnew) - end if - else - tmp(1:nnew) = init_val - end if - call move_alloc(tmp, arr) + + + if (allocated(self%k_plpl)) deallocate(self%k_plpl) return - end subroutine swiftest_util_resize_arr_I4B + end subroutine swiftest_util_resize_pl - module subroutine swiftest_util_resize_arr_info(arr, nnew) + module subroutine swiftest_util_resize_tp(self, nnew) !! author: David A. Minton !! - !! Resizes an array component of type character string. Array will only be resized if has previously been allocated. Passing nnew = 0 will deallocate. - implicit none - ! Arguments - type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size - ! Internals - type(swiftest_particle_info), dimension(:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated - integer(I4B) :: nold !! Old size - - if (nnew < 0) return - - if (nnew == 0) then - if (allocated(arr)) deallocate(arr) - return - end if - - if (allocated(arr)) then - nold = size(arr) - else - nold = 0 - end if - - if (nnew == nold) return - - allocate(tmp(nnew)) - if (nnew > nold) then - call swiftest_util_copy_particle_info_arr(arr(1:nold), tmp(1:nold)) - else - call swiftest_util_copy_particle_info_arr(arr(1:nnew), tmp(1:nnew)) - end if - - call move_alloc(tmp, arr) - - return - end subroutine swiftest_util_resize_arr_info - - - module subroutine swiftest_util_resize_arr_kin(arr, nnew) - !! author: David A. Minton - !! - !! Resizes an array component of type character string. Array will only be resized if has previously been allocated. Passing nnew = 0 will deallocate. - implicit none - ! Arguments - type(swiftest_kinship), dimension(:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size - ! Internals - type(swiftest_kinship), dimension(:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated - integer(I4B) :: nold !! Old size - - if (nnew < 0) return - - if (nnew == 0) then - if (allocated(arr)) deallocate(arr) - return - end if - - if (allocated(arr)) then - nold = size(arr) - else - nold = 0 - end if - - allocate(tmp(nnew)) - if (nnew > nold) then - tmp(1:nold) = arr(1:nold) - else - tmp(1:nnew) = arr(1:nnew) - end if - call move_alloc(tmp, arr) - - return - end subroutine swiftest_util_resize_arr_kin - - - module subroutine swiftest_util_resize_arr_logical(arr, nnew) - !! author: David A. Minton - !! - !! Resizes an array component of logical type. Passing nnew = 0 will deallocate. - implicit none - ! Arguments - logical, dimension(:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size - ! Internals - logical, dimension(:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated - integer(I4B) :: nold !! Old size - logical, parameter :: init_val = .false. - - if (nnew < 0) return - - if (nnew == 0) then - if (allocated(arr)) deallocate(arr) - return - end if - - if (allocated(arr)) then - nold = size(arr) - else - nold = 0 - end if - - if (nnew == nold) return - - allocate(tmp(nnew)) - if (nold > 0) then - if (nnew > nold) then - tmp(1:nold) = arr(1:nold) - tmp(nold+1:nnew) = init_val - else - tmp(1:nnew) = arr(1:nnew) - end if - else - tmp(1:nnew) = init_val - end if - call move_alloc(tmp, arr) - - return - end subroutine swiftest_util_resize_arr_logical - - - module subroutine swiftest_util_resize_body(self, nnew) - !! author: David A. Minton - !! - !! Checks the current size of a Swiftest body against the requested size and resizes it if it is too small. - implicit none - ! Arguments - class(swiftest_body), intent(inout) :: self !! Swiftest body object - integer(I4B), intent(in) :: nnew !! New size neded - - call swiftest_util_resize(self%info, nnew) - call swiftest_util_resize(self%id, nnew) - call swiftest_util_resize(self%status, nnew) - call swiftest_util_resize(self%lcollision, nnew) - call swiftest_util_resize(self%lencounter, nnew) - call swiftest_util_resize(self%ldiscard, nnew) - call swiftest_util_resize(self%lmask, nnew) - call swiftest_util_resize(self%mu, nnew) - call swiftest_util_resize(self%rh, nnew) - call swiftest_util_resize(self%vh, nnew) - call swiftest_util_resize(self%rb, nnew) - call swiftest_util_resize(self%vb, nnew) - call swiftest_util_resize(self%ah, nnew) - call swiftest_util_resize(self%aobl, nnew) - call swiftest_util_resize(self%atide, nnew) - call swiftest_util_resize(self%agr, nnew) - call swiftest_util_resize(self%ir3h, nnew) - call swiftest_util_resize(self%a, nnew) - call swiftest_util_resize(self%e, nnew) - call swiftest_util_resize(self%inc, nnew) - call swiftest_util_resize(self%capom, nnew) - call swiftest_util_resize(self%omega, nnew) - call swiftest_util_resize(self%capm, nnew) - self%nbody = count(self%status(1:nnew) /= INACTIVE) - - return - end subroutine swiftest_util_resize_body - - - module subroutine swiftest_util_resize_pl(self, nnew) - !! author: David A. Minton - !! - !! Checks the current size of a Swiftest massive body against the requested size and resizes it if it is too small. - implicit none - ! Arguments - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - integer(I4B), intent(in) :: nnew !! New size neded - - call swiftest_util_resize_body(self, nnew) - - call swiftest_util_resize(self%mass, nnew) - call swiftest_util_resize(self%Gmass, nnew) - call swiftest_util_resize(self%rhill, nnew) - call swiftest_util_resize(self%renc, nnew) - call swiftest_util_resize(self%radius, nnew) - call swiftest_util_resize(self%rbeg, nnew) - call swiftest_util_resize(self%rend, nnew) - call swiftest_util_resize(self%vbeg, nnew) - call swiftest_util_resize(self%density, nnew) - call swiftest_util_resize(self%Ip, nnew) - call swiftest_util_resize(self%rot, nnew) - call swiftest_util_resize(self%k2, nnew) - call swiftest_util_resize(self%Q, nnew) - call swiftest_util_resize(self%tlag, nnew) - call swiftest_util_resize(self%kin, nnew) - call swiftest_util_resize(self%lmtiny, nnew) - call swiftest_util_resize(self%nplenc, nnew) - call swiftest_util_resize(self%ntpenc, nnew) - - - - if (allocated(self%k_plpl)) deallocate(self%k_plpl) - - return - end subroutine swiftest_util_resize_pl - - - module subroutine swiftest_util_resize_tp(self, nnew) - !! author: David A. Minton - !! - !! Checks the current size of a Swiftest test particle against the requested size and resizes it if it is too small. + !! Checks the current size of a Swiftest test particle against the requested size and resizes it if it is too small. implicit none ! Arguments class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object @@ -2441,10 +1977,10 @@ module subroutine swiftest_util_resize_tp(self, nnew) call swiftest_util_resize_body(self, nnew) - call swiftest_util_resize(self%nplenc, nnew) - call swiftest_util_resize(self%isperi, nnew) - call swiftest_util_resize(self%peri, nnew) - call swiftest_util_resize(self%atp, nnew) + call util_resize(self%nplenc, nnew) + call util_resize(self%isperi, nnew) + call util_resize(self%peri, nnew) + call util_resize(self%atp, nnew) return end subroutine swiftest_util_resize_tp @@ -2695,8 +2231,8 @@ module subroutine swiftest_util_set_rhill_approximate(self,cb) return end subroutine swiftest_util_set_rhill_approximate - module subroutine swiftest_util_setup_construct_system(nbody_system, param) + !! author: David A. Minton !! !! Constructor for a Swiftest nbody system. Creates the nbody system object based on the user-input integrator @@ -2704,13 +2240,11 @@ module subroutine swiftest_util_setup_construct_system(nbody_system, param) implicit none ! Arguments class(swiftest_nbody_system), allocatable, intent(inout) :: nbody_system !! Swiftest nbody_system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters select case(param%integrator) case (INT_BS) write(*,*) 'Bulirsch-Stoer integrator not yet enabled' - case (INT_HELIO) - allocate(helio_nbody_system :: nbody_system) + case (INT_HELIO) select type(nbody_system) class is (helio_nbody_system) allocate(helio_cb :: nbody_system%cb) @@ -2769,10 +2303,8 @@ module subroutine swiftest_util_setup_construct_system(nbody_system, param) allocate(swiftest_particle_info :: nbody_system%cb%info) - nbody_system%t = param%tstart - return end subroutine swiftest_util_setup_construct_system @@ -2810,26 +2342,28 @@ module subroutine swiftest_util_setup_initialize_particle_info_system(self, para end subroutine swiftest_util_setup_initialize_particle_info_system - module subroutine swiftest_util_setup_initialize_system(self, param) + module subroutine swiftest_util_setup_initialize_system(self, system_history, param) !! author: David A. Minton !! !! Wrapper method to initialize a basic Swiftest nbody system from files !! implicit none ! Arguments - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody_system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody_system object + class(swiftest_storage), allocatable, intent(inout) :: system_history !! Stores the system history between output dumps + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - if (allocated(self%system_history)) then - call self%system_history%dealloc() - deallocate(self%system_history) + ! Internals + if (allocated(system_history)) then + call system_history%dealloc() + deallocate(system_history) end if - allocate(swiftest_storage :: self%system_history) - call self%system_history%setup(param%dump_cadence) - allocate(swiftest_netcdf_parameters :: self%system_history%nc) + allocate(swiftest_storage :: system_history) + call system_history%setup(param%dump_cadence) + allocate(swiftest_netcdf_parameters :: system_history%nc) - associate(nbody_system => self, cb => self%cb, pl => self%pl, tp => self%tp, nc => self%system_history%nc) - call nbody_system%read_in(param) + associate(nbody_system => self, cb => self%cb, pl => self%pl, tp => self%tp, nc => system_history%nc) + call nbody_system%read_in(nc, param) call nbody_system%validate_ids(param) call nbody_system%set_msys() call pl%set_mu(cb) @@ -2849,7 +2383,7 @@ module subroutine swiftest_util_setup_initialize_system(self, param) ! Write initial conditions to file nc%file_name = param%outfile - call nbody_system%write_frame(param) + call nbody_system%initialize_output_file(nc, param) call nc%close() end associate @@ -2892,7 +2426,6 @@ module subroutine swiftest_util_setup_body(self, n, param) allocate(self%vb(NDIM, n)) allocate(self%ah(NDIM, n)) allocate(self%ir3h(n)) - allocate(self%aobl(NDIM, n)) allocate(self%isperi(n)) allocate(self%peri(n)) allocate(self%atp(n)) @@ -2931,11 +2464,14 @@ module subroutine swiftest_util_setup_body(self, n, param) self%vb(:,:) = 0.0_DP self%ah(:,:) = 0.0_DP self%ir3h(:) = 0.0_DP - self%aobl(:,:) = 0.0_DP self%isperi(:) = 1 self%peri(:) = 0.0_DP self%atp(:) = 0.0_DP + if (param%loblatecb) then + allocate(self%aobl(NDIM, n)) + self%aobl(:,:) = 0.0_DP + end if if (param%ltides) then allocate(self%atide(NDIM, n)) self%atide(:,:) = 0.0_DP @@ -3049,11 +2585,11 @@ module subroutine swiftest_util_snapshot_system(self, param, nbody_system, t, ar !! Takes a snapshot of the nbody_system for later file storage implicit none ! Arguments - class(swiftest_storage), intent(inout) :: self !! Swiftest storage object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - class(swiftest_nbody_system), intent(inout) :: nbody_system !! Swiftest nbody system object to store - real(DP), intent(in), optional :: t !! Time of snapshot if different from nbody_system time - character(*), intent(in), optional :: arg !! Optional argument (needed for extended storage type used in collision snapshots) + class(swiftest_storage), intent(inout) :: self !! Swiftest storage object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(swiftest_nbody_system), intent(inout) :: nbody_system !! Swiftest nbody system object to store + real(DP), intent(in), optional :: t !! Time of snapshot if different from nbody_system time + character(*), intent(in), optional :: arg !! Optional argument (needed for extended storage type used in collision snapshots) ! Internals class(swiftest_nbody_system), allocatable :: snapshot @@ -3080,9 +2616,6 @@ module subroutine swiftest_util_snapshot_system(self, param, nbody_system, t, ar allocate(snapshot%cb, source=nbody_system%cb ) allocate(snapshot%pl, source=nbody_system%pl ) allocate(snapshot%tp, source=nbody_system%tp ) - allocate(snapshot%system_history) - allocate(snapshot%system_history%nc, source=nbody_system%system_history%nc) - snapshot%system_history%nc%lfile_is_open = .true. snapshot%t = nbody_system%t snapshot%GMtot = nbody_system%GMtot @@ -3161,25 +2694,25 @@ module subroutine swiftest_util_sort_body(self, sortby, ascending) associate(body => self, n => self%nbody) select case(sortby) case("id") - call swiftest_util_sort(direction * body%id(1:n), ind) + call util_sort(direction * body%id(1:n), ind) case("status") - call swiftest_util_sort(direction * body%status(1:n), ind) + call util_sort(direction * body%status(1:n), ind) case("ir3h") - call swiftest_util_sort(direction * body%ir3h(1:n), ind) + call util_sort(direction * body%ir3h(1:n), ind) case("a") - call swiftest_util_sort(direction * body%a(1:n), ind) + call util_sort(direction * body%a(1:n), ind) case("e") - call swiftest_util_sort(direction * body%e(1:n), ind) + call util_sort(direction * body%e(1:n), ind) case("inc") - call swiftest_util_sort(direction * body%inc(1:n), ind) + call util_sort(direction * body%inc(1:n), ind) case("capom") - call swiftest_util_sort(direction * body%capom(1:n), ind) + call util_sort(direction * body%capom(1:n), ind) case("mu") - call swiftest_util_sort(direction * body%mu(1:n), ind) + call util_sort(direction * body%mu(1:n), ind) case("peri") - call swiftest_util_sort(direction * body%peri(1:n), ind) + call util_sort(direction * body%peri(1:n), ind) case("atp") - call swiftest_util_sort(direction * body%atp(1:n), ind) + call util_sort(direction * body%atp(1:n), ind) case("info", "lfirst", "nbody", "ldiscard", "lcollision", "lencounter", "rh", "vh", "rb", "vb", "ah", "aobl", "atide", "agr","isperi") write(*,*) 'Cannot sort by ' // trim(adjustl(sortby)) // '. Component not sortable!' case default @@ -3195,839 +2728,150 @@ module subroutine swiftest_util_sort_body(self, sortby, ascending) end subroutine swiftest_util_sort_body - pure module subroutine swiftest_util_sort_dp(arr) + module subroutine swiftest_util_sort_pl(self, sortby, ascending) !! author: David A. Minton !! - !! Sort input DP precision array in place into ascending numerical order using quicksort. - !! + !! Sort a Swiftest massive body object in-place. + !! sortby is a string indicating which array component to sort. implicit none ! Arguments - real(DP), dimension(:), intent(inout) :: arr + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + character(*), intent(in) :: sortby !! Sorting attribute + logical, intent(in) :: ascending !! Logical flag indicating whether or not the sorting should be in ascending or descending order + ! Internals + integer(I4B), dimension(:), allocatable :: ind + integer(I4B) :: direction - call swiftest_util_sort_qsort_DP(arr) + if (self%nbody == 0) return - return - end subroutine swiftest_util_sort_dp + if (ascending) then + direction = 1 + else + direction = -1 + end if + associate(pl => self, npl => self%nbody) + select case(sortby) + case("Gmass","mass") + call util_sort(direction * pl%Gmass(1:npl), ind) + case("rhill") + call util_sort(direction * pl%rhill(1:npl), ind) + case("renc") + call util_sort(direction * pl%renc(1:npl), ind) + case("radius") + call util_sort(direction * pl%radius(1:npl), ind) + case("density") + call util_sort(direction * pl%density(1:npl), ind) + case("k2") + call util_sort(direction * pl%k2(1:npl), ind) + case("Q") + call util_sort(direction * pl%Q(1:npl), ind) + case("tlag") + call util_sort(direction * pl%tlag(1:npl), ind) + case("nplenc") + call util_sort(direction * pl%nplenc(1:npl), ind) + case("ntpenc") + call util_sort(direction * pl%ntpenc(1:npl), ind) + case("lmtiny", "nplm", "nplplm", "kin", "rbeg", "rend", "vbeg", "Ip", "rot", "k_plpl", "nplpl") + write(*,*) 'Cannot sort by ' // trim(adjustl(sortby)) // '. Component not sortable!' + case default ! Look for components in the parent class + call swiftest_util_sort_body(pl, sortby, ascending) + return + end select - pure module subroutine swiftest_util_sort_index_dp(arr, ind) - !! author: David A. Minton - !! - !! Sort input DP precision array by index in ascending numerical order using quick sort. - !! This algorithm works well for partially sorted arrays (which is usually the case here). - !! If ind is supplied already allocated, we assume it is an existing index array (e.g. a previously - !! sorted array). If it is not allocated, this subroutine swiftest_allocates it. - !! - implicit none - ! Arguments - real(DP), dimension(:), intent(in) :: arr - integer(I4B), dimension(:), allocatable, intent(inout) :: ind - ! Internals - integer(I4B) :: n, i - real(DP), dimension(:), allocatable :: tmparr + call pl%rearrange(ind) + + end associate - n = size(arr) - if (.not.allocated(ind)) then - allocate(ind(n)) - ind = [(i, i=1, n)] - end if - allocate(tmparr, mold=arr) - tmparr(:) = arr(ind(:)) - call swiftest_util_sort_qsort_DP(tmparr, ind) - return - end subroutine swiftest_util_sort_index_dp + end subroutine swiftest_util_sort_pl - recursive pure subroutine swiftest_util_sort_qsort_DP(arr, ind) + module subroutine swiftest_util_sort_tp(self, sortby, ascending) !! author: David A. Minton !! - !! Sort input DP precision array by index in ascending numerical order using quicksort sort. - !! + !! Sort a Swiftest test particle object in-place. + !! sortby is a string indicating which array component to sort. implicit none ! Arguments - real(DP), dimension(:), intent(inout) :: arr - integer(I4B),dimension(:),intent(out), optional :: ind - !! Internals - integer :: iq - - if (size(arr) > 1) then - if (present(ind)) then - call swiftest_util_sort_partition_DP(arr, iq, ind) - call swiftest_util_sort_qsort_DP(arr(:iq-1),ind(:iq-1)) - call swiftest_util_sort_qsort_DP(arr(iq:), ind(iq:)) - else - call swiftest_util_sort_partition_DP(arr, iq) - call swiftest_util_sort_qsort_DP(arr(:iq-1)) - call swiftest_util_sort_qsort_DP(arr(iq:)) - end if + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + character(*), intent(in) :: sortby !! Sorting attribute + logical, intent(in) :: ascending !! Logical flag indicating whether or not the sorting should be in ascending or descending order + ! Internals + integer(I4B), dimension(:), allocatable :: ind + integer(I4B) :: direction + + if (self%nbody == 0) return + + if (ascending) then + direction = 1 + else + direction = -1 end if - return - end subroutine swiftest_util_sort_qsort_DP + associate(tp => self, ntp => self%nbody) + select case(sortby) + case("nplenc") + call util_sort(direction * tp%nplenc(1:ntp), ind) + case default ! Look for components in the parent class + call swiftest_util_sort_body(tp, sortby, ascending) + return + end select - - pure subroutine swiftest_util_sort_partition_DP(arr, marker, ind) - !! author: David A. Minton - !! - !! Partition function for quicksort on DP type - !! - implicit none - ! Arguments - real(DP), intent(inout), dimension(:) :: arr - integer(I4B), intent(inout), dimension(:), optional :: ind - integer(I4B), intent(out) :: marker - ! Internals - integer(I4B) :: i, j, itmp, narr, ipiv - real(DP) :: temp - real(DP) :: x ! pivot point + call tp%rearrange(ind) - narr = size(arr) + end associate - ! Get center as pivot, as this is likely partially sorted - ipiv = narr / 2 - x = arr(ipiv) - i = 0 - j = narr + 1 - - do - j = j - 1 - do - if (arr(j) <= x) exit - j = j - 1 - end do - i = i + 1 - do - if (arr(i) >= x) exit - i = i + 1 - end do - if (i < j) then - ! exchange A(i) and A(j) - temp = arr(i) - arr(i) = arr(j) - arr(j) = temp - if (present(ind)) then - itmp = ind(i) - ind(i) = ind(j) - ind(j) = itmp - end if - else if (i == j) then - marker = i + 1 - return - else - marker = i - return - endif - end do - return - end subroutine swiftest_util_sort_partition_DP - + end subroutine swiftest_util_sort_tp - pure module subroutine swiftest_util_sort_i4b(arr) + module subroutine swiftest_util_sort_rearrange_body(self, ind) !! author: David A. Minton !! - !! Sort input integer array in place into ascending numerical order using quick sort. - !! This algorithm works well for partially sorted arrays (which is usually the case here) - !! + !! Rearrange Swiftest body structure in-place from an index list. + !! This is a helper utility used to make polymorphic sorting work on Swiftest structures. implicit none ! Arguments - integer(I4B), dimension(:), intent(inout) :: arr + class(swiftest_body), intent(inout) :: self !! Swiftest body object + integer(I4B), dimension(:), intent(in) :: ind !! Index array used to restructure the body (should contain all 1:n index values in the desired order) - call swiftest_util_sort_qsort_I4B(arr) + associate(n => self%nbody) + call util_sort_rearrange(self%id, ind, n) + call util_sort_rearrange(self%lmask, ind, n) + call util_sort_rearrange(self%info, ind, n) + call util_sort_rearrange(self%status, ind, n) + call util_sort_rearrange(self%ldiscard, ind, n) + call util_sort_rearrange(self%lcollision, ind, n) + call util_sort_rearrange(self%lencounter, ind, n) + call util_sort_rearrange(self%rh, ind, n) + call util_sort_rearrange(self%vh, ind, n) + call util_sort_rearrange(self%rb, ind, n) + call util_sort_rearrange(self%vb, ind, n) + call util_sort_rearrange(self%ah, ind, n) + call util_sort_rearrange(self%aobl, ind, n) + call util_sort_rearrange(self%agr, ind, n) + call util_sort_rearrange(self%atide, ind, n) + call util_sort_rearrange(self%ir3h, ind, n) + call util_sort_rearrange(self%isperi, ind, n) + call util_sort_rearrange(self%peri, ind, n) + call util_sort_rearrange(self%atp, ind, n) + call util_sort_rearrange(self%mu, ind, n) + call util_sort_rearrange(self%a, ind, n) + call util_sort_rearrange(self%e, ind, n) + call util_sort_rearrange(self%inc, ind, n) + call util_sort_rearrange(self%capom, ind, n) + call util_sort_rearrange(self%omega, ind, n) + call util_sort_rearrange(self%capm, ind, n) + end associate return - end subroutine swiftest_util_sort_i4b + end subroutine swiftest_util_sort_rearrange_body - pure module subroutine swiftest_util_sort_index_I4B(arr, ind) + module subroutine swiftest_util_sort_rearrange_arr_info(arr, ind, n) !! author: David A. Minton !! - !! Sort input integer array by index in ascending numerical order using quicksort. - !! If ind is supplied already allocated, we assume it is an existing index array (e.g. a previously - !! sorted array). If it is not allocated, this subroutine swiftest_allocates it. - !! - implicit none - ! Arguments - integer(I4B), dimension(:), intent(in) :: arr - integer(I4B), dimension(:), allocatable, intent(inout) :: ind - ! Internals - integer(I4B) :: n, i - integer(I4B), dimension(:), allocatable :: tmparr - - n = size(arr) - if (.not.allocated(ind)) then - allocate(ind(n)) - ind = [(i, i=1, n)] - end if - allocate(tmparr, mold=arr) - tmparr(:) = arr(ind(:)) - call swiftest_util_sort_qsort_I4B(tmparr, ind) - - return - end subroutine swiftest_util_sort_index_I4B - - - pure module subroutine swiftest_util_sort_index_I4B_I8Bind(arr, ind) - !! author: David A. Minton - !! - !! Sort input integer array by index in ascending numerical order using quicksort. - !! If ind is supplied already allocated, we assume it is an existing index array (e.g. a previously - !! sorted array). If it is not allocated, this subroutine swiftest_allocates it. - !! - implicit none - ! Arguments - integer(I4B), dimension(:), intent(in) :: arr - integer(I8B), dimension(:), allocatable, intent(inout) :: ind - ! Internals - integer(I8B) :: n, i - integer(I4B), dimension(:), allocatable :: tmparr - - n = size(arr) - if (.not.allocated(ind)) then - allocate(ind(n)) - ind = [(i, i=1_I8B, n)] - end if - allocate(tmparr, mold=arr) - tmparr(:) = arr(ind(:)) - call swiftest_util_sort_qsort_I4B_I8Bind(tmparr, ind) - - return - end subroutine swiftest_util_sort_index_I4B_I8Bind - - - recursive pure subroutine swiftest_util_sort_qsort_I4B(arr, ind) - !! author: David A. Minton - !! - !! Sort input I4B array by index in ascending numerical order using quicksort. - !! - implicit none - ! Arguments - integer(I4B), dimension(:), intent(inout) :: arr - integer(I4B), dimension(:), intent(out), optional :: ind - ! Internals - integer(I4B) :: iq - - if (size(arr) > 1) then - if (present(ind)) then - call swiftest_util_sort_partition_I4B(arr, iq, ind) - call swiftest_util_sort_qsort_I4B(arr(:iq-1),ind(:iq-1)) - call swiftest_util_sort_qsort_I4B(arr(iq:), ind(iq:)) - else - call swiftest_util_sort_partition_I4B(arr, iq) - call swiftest_util_sort_qsort_I4B(arr(:iq-1)) - call swiftest_util_sort_qsort_I4B(arr(iq:)) - end if - end if - - return - end subroutine swiftest_util_sort_qsort_I4B - - - recursive pure subroutine swiftest_util_sort_qsort_I4B_I8Bind(arr, ind) - !! author: David A. Minton - !! - !! Sort input I4B array by index in ascending numerical order using quicksort. - !! - implicit none - ! Arguments - integer(I4B), dimension(:), intent(inout) :: arr - integer(I8B), dimension(:), intent(out), optional :: ind - ! Internals - integer(I8B) :: iq - - if (size(arr) > 1_I8B) then - if (present(ind)) then - call swiftest_util_sort_partition_I4B_I8Bind(arr, iq, ind) - call swiftest_util_sort_qsort_I4B_I8Bind(arr(:iq-1_I8B),ind(:iq-1_I8B)) - call swiftest_util_sort_qsort_I4B_I8Bind(arr(iq:), ind(iq:)) - else - call swiftest_util_sort_partition_I4B_I8Bind(arr, iq) - call swiftest_util_sort_qsort_I4B_I8Bind(arr(:iq-1_I8B)) - call swiftest_util_sort_qsort_I4B_I8Bind(arr(iq:)) - end if - end if - - return - end subroutine swiftest_util_sort_qsort_I4B_I8Bind - - - recursive pure subroutine swiftest_util_sort_qsort_I8B_I8Bind(arr, ind) - !! author: David A. Minton - !! - !! Sort input I8B array by index in ascending numerical order using quicksort. - !! - implicit none - ! Arguments - integer(I8B), dimension(:), intent(inout) :: arr - integer(I8B), dimension(:), intent(out), optional :: ind - ! Internals - integer(I8B) :: iq - - if (size(arr) > 1_I8B) then - if (present(ind)) then - call swiftest_util_sort_partition_I8B_I8Bind(arr, iq, ind) - call swiftest_util_sort_qsort_I8B_I8Bind(arr(:iq-1_I8B),ind(:iq-1_I8B)) - call swiftest_util_sort_qsort_I8B_I8Bind(arr(iq:), ind(iq:)) - else - call swiftest_util_sort_partition_I8B_I8Bind(arr, iq) - call swiftest_util_sort_qsort_I8B_I8Bind(arr(:iq-1_I8B)) - call swiftest_util_sort_qsort_I8B_I8Bind(arr(iq:)) - end if - end if - - return - end subroutine swiftest_util_sort_qsort_I8B_I8Bind - - - pure subroutine swiftest_util_sort_partition_I4B(arr, marker, ind) - !! author: David A. Minton - !! - !! Partition function for quicksort on I4B type - !! - implicit none - ! Arguments - integer(I4B), intent(inout), dimension(:) :: arr - integer(I4B), intent(inout), dimension(:), optional :: ind - integer(I4B), intent(out) :: marker - ! Internals - integer(I4B) :: i, j, itmp, narr, ipiv - integer(I4B) :: temp - integer(I4B) :: x ! pivot point - - narr = size(arr) - - ! Get center as pivot, as this is likely partially sorted - ipiv = narr / 2 - x = arr(ipiv) - i = 0 - j = narr + 1 - - do - j = j - 1 - do - if (arr(j) <= x) exit - j = j - 1 - end do - i = i + 1 - do - if (arr(i) >= x) exit - i = i + 1 - end do - if (i < j) then - ! exchange A(i) and A(j) - temp = arr(i) - arr(i) = arr(j) - arr(j) = temp - if (present(ind)) then - itmp = ind(i) - ind(i) = ind(j) - ind(j) = itmp - end if - else if (i == j) then - marker = i + 1 - return - else - marker = i - return - endif - end do - - return - end subroutine swiftest_util_sort_partition_I4B - - - pure subroutine swiftest_util_sort_partition_I4B_I8Bind(arr, marker, ind) - !! author: David A. Minton - !! - !! Partition function for quicksort on I4B type - !! - implicit none - ! Arguments - integer(I4B), intent(inout), dimension(:) :: arr - integer(I8B), intent(inout), dimension(:), optional :: ind - integer(I8B), intent(out) :: marker - ! Internals - integer(I8B) :: i, j, itmp, narr, ipiv - integer(I4B) :: temp - integer(I8B) :: x ! pivot point - - narr = size(arr) - - ! Get center as pivot, as this is likely partially sorted - ipiv = narr / 2_I8B - x = arr(ipiv) - i = 0_I8B - j = narr + 1_I8B - - do - j = j - 1_I8B - do - if (arr(j) <= x) exit - j = j - 1_I8B - end do - i = i + 1_I8B - do - if (arr(i) >= x) exit - i = i + 1_I8B - end do - if (i < j) then - ! exchange A(i) and A(j) - temp = arr(i) - arr(i) = arr(j) - arr(j) = temp - if (present(ind)) then - itmp = ind(i) - ind(i) = ind(j) - ind(j) = itmp - end if - else if (i == j) then - marker = i + 1_I8B - return - else - marker = i - return - endif - end do - - return - end subroutine swiftest_util_sort_partition_I4B_I8Bind - - - pure subroutine swiftest_util_sort_partition_I8B_I8Bind(arr, marker, ind) - !! author: David A. Minton - !! - !! Partition function for quicksort on I8B type with I8B index - !! - implicit none - ! Arguments - integer(I8B), intent(inout), dimension(:) :: arr - integer(I8B), intent(inout), dimension(:), optional :: ind - integer(I8B), intent(out) :: marker - ! Internals - integer(I8B) :: i, j, itmp, narr, ipiv - integer(I8B) :: temp - integer(I8B) :: x ! pivot point - - narr = size(arr) - - ! Get center as pivot, as this is likely partially sorted - ipiv = narr / 2_I8B - x = arr(ipiv) - i = 0_I8B - j = narr + 1_I8B - - do - j = j - 1_I8B - do - if (arr(j) <= x) exit - j = j - 1_I8B - end do - i = i + 1_I8B - do - if (arr(i) >= x) exit - i = i + 1_I8B - end do - if (i < j) then - ! exchange A(i) and A(j) - temp = arr(i) - arr(i) = arr(j) - arr(j) = temp - if (present(ind)) then - itmp = ind(i) - ind(i) = ind(j) - ind(j) = itmp - end if - else if (i == j) then - marker = i + 1_I8B - return - else - marker = i - return - endif - end do - - return - end subroutine swiftest_util_sort_partition_I8B_I8Bind - - - pure module subroutine swiftest_util_sort_sp(arr) - !! author: David A. Minton - !! - !! Sort input DP precision array in place into ascending numerical order using quicksort. - !! - implicit none - ! Arguments - real(SP), dimension(:), intent(inout) :: arr - - call swiftest_util_sort_qsort_SP(arr) - - return - end subroutine swiftest_util_sort_sp - - - pure module subroutine swiftest_util_sort_index_sp(arr, ind) - !! author: David A. Minton - !! - !! Sort input DP precision array by index in ascending numerical order using quicksort. - !! If ind is supplied already allocated, we assume it is an existing index array (e.g. a previously - !! sorted array). If it is not allocated, this subroutine swiftest_allocates it. - !! - implicit none - ! Arguments - real(SP), dimension(:), intent(in) :: arr - integer(I4B), dimension(:), allocatable, intent(inout) :: ind - ! Internals - integer(I4B) :: n, i - real(SP), dimension(:), allocatable :: tmparr - - n = size(arr) - if (.not.allocated(ind)) then - allocate(ind(n)) - ind = [(i, i=1, n)] - end if - allocate(tmparr, mold=arr) - tmparr(:) = arr(ind(:)) - call swiftest_util_sort_qsort_SP(tmparr, ind) - - return - end subroutine swiftest_util_sort_index_sp - - - recursive pure subroutine swiftest_util_sort_qsort_SP(arr, ind) - !! author: David A. Minton - !! - !! Sort input DP precision array by index in ascending numerical order using quicksort. - !! - implicit none - ! Arguments - real(SP), dimension(:), intent(inout) :: arr - integer(I4B),dimension(:),intent(out), optional :: ind - !! Internals - integer :: iq - - if (size(arr) > 1) then - if (present(ind)) then - call swiftest_util_sort_partition_SP(arr, iq, ind) - call swiftest_util_sort_qsort_SP(arr(:iq-1),ind(:iq-1)) - call swiftest_util_sort_qsort_SP(arr(iq:), ind(iq:)) - else - call swiftest_util_sort_partition_SP(arr, iq) - call swiftest_util_sort_qsort_SP(arr(:iq-1)) - call swiftest_util_sort_qsort_SP(arr(iq:)) - end if - end if - - return - end subroutine swiftest_util_sort_qsort_SP - - - pure subroutine swiftest_util_sort_partition_SP(arr, marker, ind) - !! author: David A. Minton - !! - !! Partition function for quicksort on SP type - !! - implicit none - ! Arguments - real(SP), intent(inout), dimension(:) :: arr - integer(I4B), intent(inout), dimension(:), optional :: ind - integer(I4B), intent(out) :: marker - ! Internals - integer(I4B) :: i, j, itmp, narr, ipiv - real(SP) :: temp - real(SP) :: x ! pivot point - - narr = size(arr) - - ! Get center as pivot, as this is likely partially sorted - ipiv = narr / 2 - x = arr(ipiv) - i = 0 - j = narr + 1 - - do - j = j - 1 - do - if (arr(j) <= x) exit - j = j - 1 - end do - i = i + 1 - do - if (arr(i) >= x) exit - i = i + 1 - end do - if (i < j) then - ! exchange A(i) and A(j) - temp = arr(i) - arr(i) = arr(j) - arr(j) = temp - if (present(ind)) then - itmp = ind(i) - ind(i) = ind(j) - ind(j) = itmp - end if - else if (i == j) then - marker = i + 1 - return - else - marker = i - return - endif - end do - - return - end subroutine swiftest_util_sort_partition_SP - - - module subroutine swiftest_util_sort_pl(self, sortby, ascending) - !! author: David A. Minton - !! - !! Sort a Swiftest massive body object in-place. - !! sortby is a string indicating which array component to sort. - implicit none - ! Arguments - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - character(*), intent(in) :: sortby !! Sorting attribute - logical, intent(in) :: ascending !! Logical flag indicating whether or not the sorting should be in ascending or descending order - ! Internals - integer(I4B), dimension(:), allocatable :: ind - integer(I4B) :: direction - - if (self%nbody == 0) return - - if (ascending) then - direction = 1 - else - direction = -1 - end if - - associate(pl => self, npl => self%nbody) - select case(sortby) - case("Gmass","mass") - call swiftest_util_sort(direction * pl%Gmass(1:npl), ind) - case("rhill") - call swiftest_util_sort(direction * pl%rhill(1:npl), ind) - case("renc") - call swiftest_util_sort(direction * pl%renc(1:npl), ind) - case("radius") - call swiftest_util_sort(direction * pl%radius(1:npl), ind) - case("density") - call swiftest_util_sort(direction * pl%density(1:npl), ind) - case("k2") - call swiftest_util_sort(direction * pl%k2(1:npl), ind) - case("Q") - call swiftest_util_sort(direction * pl%Q(1:npl), ind) - case("tlag") - call swiftest_util_sort(direction * pl%tlag(1:npl), ind) - case("nplenc") - call swiftest_util_sort(direction * pl%nplenc(1:npl), ind) - case("ntpenc") - call swiftest_util_sort(direction * pl%ntpenc(1:npl), ind) - case("lmtiny", "nplm", "nplplm", "kin", "rbeg", "rend", "vbeg", "Ip", "rot", "k_plpl", "nplpl") - write(*,*) 'Cannot sort by ' // trim(adjustl(sortby)) // '. Component not sortable!' - case default ! Look for components in the parent class - call swiftest_util_sort_body(pl, sortby, ascending) - return - end select - - call pl%rearrange(ind) - - end associate - - return - end subroutine swiftest_util_sort_pl - - - module subroutine swiftest_util_sort_tp(self, sortby, ascending) - !! author: David A. Minton - !! - !! Sort a Swiftest test particle object in-place. - !! sortby is a string indicating which array component to sort. - implicit none - ! Arguments - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - character(*), intent(in) :: sortby !! Sorting attribute - logical, intent(in) :: ascending !! Logical flag indicating whether or not the sorting should be in ascending or descending order - ! Internals - integer(I4B), dimension(:), allocatable :: ind - integer(I4B) :: direction - - if (self%nbody == 0) return - - if (ascending) then - direction = 1 - else - direction = -1 - end if - - associate(tp => self, ntp => self%nbody) - select case(sortby) - case("nplenc") - call swiftest_util_sort(direction * tp%nplenc(1:ntp), ind) - case default ! Look for components in the parent class - call swiftest_util_sort_body(tp, sortby, ascending) - return - end select - - call tp%rearrange(ind) - - end associate - - return - end subroutine swiftest_util_sort_tp - - - module subroutine swiftest_util_sort_rearrange_body(self, ind) - !! author: David A. Minton - !! - !! Rearrange Swiftest body structure in-place from an index list. - !! This is a helper utility used to make polymorphic sorting work on Swiftest structures. - implicit none - ! Arguments - class(swiftest_body), intent(inout) :: self !! Swiftest body object - integer(I4B), dimension(:), intent(in) :: ind !! Index array used to restructure the body (should contain all 1:n index values in the desired order) - - associate(n => self%nbody) - call swiftest_util_sort_rearrange(self%id, ind, n) - call swiftest_util_sort_rearrange(self%lmask, ind, n) - call swiftest_util_sort_rearrange(self%info, ind, n) - call swiftest_util_sort_rearrange(self%status, ind, n) - call swiftest_util_sort_rearrange(self%ldiscard, ind, n) - call swiftest_util_sort_rearrange(self%lcollision, ind, n) - call swiftest_util_sort_rearrange(self%lencounter, ind, n) - call swiftest_util_sort_rearrange(self%rh, ind, n) - call swiftest_util_sort_rearrange(self%vh, ind, n) - call swiftest_util_sort_rearrange(self%rb, ind, n) - call swiftest_util_sort_rearrange(self%vb, ind, n) - call swiftest_util_sort_rearrange(self%ah, ind, n) - call swiftest_util_sort_rearrange(self%aobl, ind, n) - call swiftest_util_sort_rearrange(self%agr, ind, n) - call swiftest_util_sort_rearrange(self%atide, ind, n) - call swiftest_util_sort_rearrange(self%ir3h, ind, n) - call swiftest_util_sort_rearrange(self%isperi, ind, n) - call swiftest_util_sort_rearrange(self%peri, ind, n) - call swiftest_util_sort_rearrange(self%atp, ind, n) - call swiftest_util_sort_rearrange(self%mu, ind, n) - call swiftest_util_sort_rearrange(self%a, ind, n) - call swiftest_util_sort_rearrange(self%e, ind, n) - call swiftest_util_sort_rearrange(self%inc, ind, n) - call swiftest_util_sort_rearrange(self%capom, ind, n) - call swiftest_util_sort_rearrange(self%omega, ind, n) - call swiftest_util_sort_rearrange(self%capm, ind, n) - end associate - - return - end subroutine swiftest_util_sort_rearrange_body - - - pure module subroutine swiftest_util_sort_rearrange_arr_char_string(arr, ind, n) - !! author: David A. Minton - !! - !! Rearrange a single array of character string in-place from an index list. - implicit none - ! Arguments - character(len=STRMAX), dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange - ! Internals - character(len=STRMAX), dimension(:), allocatable :: tmp !! Temporary copy of arry used during rearrange operation - - if (.not. allocated(arr) .or. n <= 0) return - allocate(tmp, mold=arr) - tmp(1:n) = arr(ind) - call move_alloc(tmp, arr) - - return - end subroutine swiftest_util_sort_rearrange_arr_char_string - - - pure module subroutine swiftest_util_sort_rearrange_arr_DP(arr, ind, n) - !! author: David A. Minton - !! - !! Rearrange a single array of DP type in-place from an index list. - implicit none - ! Arguments - real(DP), dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange - ! Internals - real(DP), dimension(:), allocatable :: tmp !! Temporary copy of array used during rearrange operation - - if (.not. allocated(arr) .or. n <= 0) return - allocate(tmp, mold=arr) - tmp(1:n) = arr(ind) - call move_alloc(tmp, arr) - - return - end subroutine swiftest_util_sort_rearrange_arr_DP - - - pure module subroutine swiftest_util_sort_rearrange_arr_DPvec(arr, ind, n) - !! author: David A. Minton - !! - !! Rearrange a single array of (NDIM,n) DP-type vectors in-place from an index list. - implicit none - ! Arguments - real(DP), dimension(:,:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange - ! Internals - real(DP), dimension(:,:), allocatable :: tmp !! Temporary copy of array used during rearrange operation - - if (.not. allocated(arr) .or. n <= 0) return - allocate(tmp, mold=arr) - tmp(:,1:n) = arr(:, ind) - call move_alloc(tmp, arr) - - return - end subroutine swiftest_util_sort_rearrange_arr_DPvec - - - pure module subroutine swiftest_util_sort_rearrange_arr_I4B(arr, ind, n) - !! author: David A. Minton - !! - !! Rearrange a single array of integers in-place from an index list. - implicit none - ! Arguments - integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange - ! Internals - integer(I4B), dimension(:), allocatable :: tmp !! Temporary copy of array used during rearrange operation - - if (.not. allocated(arr) .or. n <= 0) return - allocate(tmp, mold=arr) - tmp(1:n) = arr(ind) - call move_alloc(tmp, arr) - - return - end subroutine swiftest_util_sort_rearrange_arr_I4B - - pure module subroutine swiftest_util_sort_rearrange_arr_I4B_I8Bind(arr, ind, n) - !! author: David A. Minton - !! - !! Rearrange a single array of integers in-place from an index list. - implicit none - ! Arguments - integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I8B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I8B), intent(in) :: n !! Number of elements in arr and ind to rearrange - ! Internals - integer(I4B), dimension(:), allocatable :: tmp !! Temporary copy of array used during rearrange operation - - if (.not. allocated(arr) .or. n <= 0_I8B) return - allocate(tmp, mold=arr) - tmp(1:n) = arr(ind) - call move_alloc(tmp, arr) - - return - end subroutine swiftest_util_sort_rearrange_arr_I4B_I8Bind - - - module subroutine swiftest_util_sort_rearrange_arr_info(arr, ind, n) - !! author: David A. Minton - !! - !! Rearrange a single array of particle information type in-place from an index list. + !! Rearrange a single array of particle information type in-place from an index list. implicit none ! Arguments type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: arr !! Destination array @@ -4044,7 +2888,7 @@ module subroutine swiftest_util_sort_rearrange_arr_info(arr, ind, n) return end subroutine swiftest_util_sort_rearrange_arr_info - + pure module subroutine swiftest_util_sort_rearrange_arr_kin(arr, ind, n) !! author: David A. Minton @@ -4074,48 +2918,6 @@ pure module subroutine swiftest_util_sort_rearrange_arr_kin(arr, ind, n) end subroutine swiftest_util_sort_rearrange_arr_kin - pure module subroutine swiftest_util_sort_rearrange_arr_logical(arr, ind, n) - !! author: David A. Minton - !! - !! Rearrange a single array of logicals in-place from an index list. - implicit none - ! Arguments - logical, dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange - ! Internals - logical, dimension(:), allocatable :: tmp !! Temporary copy of array used during rearrange operation - - if (.not. allocated(arr) .or. n <= 0) return - allocate(tmp, mold=arr) - tmp(1:n) = arr(ind) - call move_alloc(tmp, arr) - - return - end subroutine swiftest_util_sort_rearrange_arr_logical - - - pure module subroutine swiftest_util_sort_rearrange_arr_logical_I8Bind(arr, ind, n) - !! author: David A. Minton - !! - !! Rearrange a single array of logicals in-place from an index list. - implicit none - ! Arguments - logical, dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I8B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I8B), intent(in) :: n !! Number of elements in arr and ind to rearrange - ! Internals - logical, dimension(:), allocatable :: tmp !! Temporary copy of array used during rearrange operation - - if (.not. allocated(arr) .or. n <= 0) return - allocate(tmp, mold=arr) - tmp(1:n) = arr(ind) - call move_alloc(tmp, arr) - - return - end subroutine swiftest_util_sort_rearrange_arr_logical_I8Bind - - module subroutine swiftest_util_sort_rearrange_pl(self, ind) !! author: David A. Minton !! @@ -4126,23 +2928,23 @@ module subroutine swiftest_util_sort_rearrange_pl(self, ind) integer(I4B), dimension(:), intent(in) :: ind !! Index array used to restructure the body (should contain all 1:n index values in the desired order) associate(pl => self, npl => self%nbody) - call swiftest_util_sort_rearrange(pl%mass, ind, npl) - call swiftest_util_sort_rearrange(pl%Gmass, ind, npl) - call swiftest_util_sort_rearrange(pl%rhill, ind, npl) - call swiftest_util_sort_rearrange(pl%renc, ind, npl) - call swiftest_util_sort_rearrange(pl%radius, ind, npl) - call swiftest_util_sort_rearrange(pl%density, ind, npl) - call swiftest_util_sort_rearrange(pl%rbeg, ind, npl) - call swiftest_util_sort_rearrange(pl%vbeg, ind, npl) - call swiftest_util_sort_rearrange(pl%Ip, ind, npl) - call swiftest_util_sort_rearrange(pl%rot, ind, npl) - call swiftest_util_sort_rearrange(pl%k2, ind, npl) - call swiftest_util_sort_rearrange(pl%Q, ind, npl) - call swiftest_util_sort_rearrange(pl%tlag, ind, npl) - call swiftest_util_sort_rearrange(pl%kin, ind, npl) - call swiftest_util_sort_rearrange(pl%lmtiny, ind, npl) - call swiftest_util_sort_rearrange(pl%nplenc, ind, npl) - call swiftest_util_sort_rearrange(pl%ntpenc, ind, npl) + call util_sort_rearrange(pl%mass, ind, npl) + call util_sort_rearrange(pl%Gmass, ind, npl) + call util_sort_rearrange(pl%rhill, ind, npl) + call util_sort_rearrange(pl%renc, ind, npl) + call util_sort_rearrange(pl%radius, ind, npl) + call util_sort_rearrange(pl%density, ind, npl) + call util_sort_rearrange(pl%rbeg, ind, npl) + call util_sort_rearrange(pl%vbeg, ind, npl) + call util_sort_rearrange(pl%Ip, ind, npl) + call util_sort_rearrange(pl%rot, ind, npl) + call util_sort_rearrange(pl%k2, ind, npl) + call util_sort_rearrange(pl%Q, ind, npl) + call util_sort_rearrange(pl%tlag, ind, npl) + call util_sort_rearrange(pl%kin, ind, npl) + call util_sort_rearrange(pl%lmtiny, ind, npl) + call util_sort_rearrange(pl%nplenc, ind, npl) + call util_sort_rearrange(pl%ntpenc, ind, npl) if (allocated(pl%k_plpl)) deallocate(pl%k_plpl) @@ -4164,7 +2966,7 @@ module subroutine swiftest_util_sort_rearrange_tp(self, ind) integer(I4B), dimension(:), intent(in) :: ind !! Index array used to restructure the body (should contain all 1:n index values in the desired order) associate(tp => self, ntp => self%nbody) - call swiftest_util_sort_rearrange(tp%nplenc, ind, ntp) + call util_sort_rearrange(tp%nplenc, ind, ntp) if (allocated(tp%k_pltp)) deallocate(tp%k_pltp) @@ -4175,220 +2977,6 @@ module subroutine swiftest_util_sort_rearrange_tp(self, ind) end subroutine swiftest_util_sort_rearrange_tp - module subroutine swiftest_util_spill_arr_char_string(keeps, discards, lspill_list, ldestructive) - !! author: David A. Minton - !! - !! Performs a spill operation on a single array of type character strings - !! This is the inverse of a spill operation - implicit none - ! Arguments - character(len=STRMAX), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - character(len=STRMAX), dimension(:), allocatable, intent(inout) :: discards !! Array of discards - logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards - logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not - ! Internals - integer(I4B) :: nspill, nkeep, nlist - character(len=STRMAX), dimension(:), allocatable :: tmp !! Array of values to keep - - nkeep = count(.not.lspill_list(:)) - nspill = count(lspill_list(:)) - nlist = size(lspill_list(:)) - - if (.not.allocated(keeps) .or. nspill == 0) return - if (.not.allocated(discards)) then - allocate(discards(nspill)) - else if (size(discards) /= nspill) then - deallocate(discards) - allocate(discards(nspill)) - end if - - discards(:) = pack(keeps(1:nlist), lspill_list(1:nlist)) - if (ldestructive) then - if (nkeep > 0) then - allocate(tmp(nkeep)) - tmp(:) = pack(keeps(1:nlist), .not. lspill_list(1:nlist)) - call move_alloc(tmp, keeps) - else - deallocate(keeps) - end if - end if - - return - end subroutine swiftest_util_spill_arr_char_string - - - module subroutine swiftest_util_spill_arr_DP(keeps, discards, lspill_list, ldestructive) - !! author: David A. Minton - !! - !! Performs a spill operation on a single array of type DP - !! This is the inverse of a spill operation - implicit none - ! Arguments - real(DP), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - real(DP), dimension(:), allocatable, intent(inout) :: discards !! Array of discards - logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discardss - logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not - ! Internals - integer(I4B) :: nspill, nkeep, nlist - real(DP), dimension(:), allocatable :: tmp !! Array of values to keep - - nkeep = count(.not.lspill_list(:)) - nspill = count(lspill_list(:)) - nlist = size(lspill_list(:)) - - if (.not.allocated(keeps) .or. nspill == 0) return - if (.not.allocated(discards)) then - allocate(discards(nspill)) - else if (size(discards) /= nspill) then - deallocate(discards) - allocate(discards(nspill)) - end if - - discards(:) = pack(keeps(1:nlist), lspill_list(1:nlist)) - if (ldestructive) then - if (nkeep > 0) then - allocate(tmp(nkeep)) - tmp(:) = pack(keeps(1:nlist), .not. lspill_list(1:nlist)) - call move_alloc(tmp, keeps) - else - deallocate(keeps) - end if - end if - - return - end subroutine swiftest_util_spill_arr_DP - - - module subroutine swiftest_util_spill_arr_DPvec(keeps, discards, lspill_list, ldestructive) - !! author: David A. Minton - !! - !! Performs a spill operation on a single array of DP vectors with shape (NDIM, n) - !! This is the inverse of a spill operation - implicit none - ! Arguments - real(DP), dimension(:,:), allocatable, intent(inout) :: keeps !! Array of values to keep - real(DP), dimension(:,:), allocatable, intent(inout) :: discards !! Array discards - logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards - logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not - ! Internals - integer(I4B) :: i, nspill, nkeep, nlist - real(DP), dimension(:,:), allocatable :: tmp !! Array of values to keep - - nkeep = count(.not.lspill_list(:)) - nspill = count(lspill_list(:)) - nlist = size(lspill_list(:)) - - if (.not.allocated(keeps) .or. nspill == 0) return - if (.not.allocated(discards)) then - allocate(discards(NDIM, nspill)) - else if (size(discards, dim=2) /= nspill) then - deallocate(discards) - allocate(discards(NDIM, nspill)) - end if - - do i = 1, NDIM - discards(i,:) = pack(keeps(i,1:nlist), lspill_list(1:nlist)) - end do - if (ldestructive) then - if (nkeep > 0) then - allocate(tmp(NDIM, nkeep)) - do i = 1, NDIM - tmp(i, :) = pack(keeps(i, 1:nlist), .not. lspill_list(1:nlist)) - end do - call move_alloc(tmp, keeps) - else - deallocate(keeps) - end if - end if - - return - end subroutine swiftest_util_spill_arr_DPvec - - - module subroutine swiftest_util_spill_arr_I4B(keeps, discards, lspill_list, ldestructive) - !! author: David A. Minton - !! - !! Performs a spill operation on a single array of type I4B - !! This is the inverse of a spill operation - implicit none - ! Arguments - integer(I4B), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - integer(I4B), dimension(:), allocatable, intent(inout) :: discards !! Array of discards - logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards - logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not - ! Internals - integer(I4B) :: nspill, nkeep, nlist - integer(I4B), dimension(:), allocatable :: tmp !! Array of values to keep - - nkeep = count(.not.lspill_list(:)) - nspill = count(lspill_list(:)) - nlist = size(lspill_list(:)) - - if (.not.allocated(keeps) .or. nspill == 0) return - if (.not.allocated(discards)) then - allocate(discards(nspill)) - else if (size(discards) /= nspill) then - deallocate(discards) - allocate(discards(nspill)) - end if - - discards(:) = pack(keeps(1:nlist), lspill_list(1:nlist)) - if (ldestructive) then - if (nkeep > 0) then - allocate(tmp(nkeep)) - tmp(:) = pack(keeps(1:nlist), .not. lspill_list(1:nlist)) - call move_alloc(tmp, keeps) - else - deallocate(keeps) - end if - end if - - return - end subroutine swiftest_util_spill_arr_I4B - - - module subroutine swiftest_util_spill_arr_I8B(keeps, discards, lspill_list, ldestructive) - !! author: David A. Minton - !! - !! Performs a spill operation on a single array of type I4B - !! This is the inverse of a spill operation - implicit none - ! Arguments - integer(I8B), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - integer(I8B), dimension(:), allocatable, intent(inout) :: discards !! Array of discards - logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards - logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not - ! Internals - integer(I4B) :: nspill, nkeep, nlist - integer(I8B), dimension(:), allocatable :: tmp !! Array of values to keep - - nkeep = count(.not.lspill_list(:)) - nspill = count(lspill_list(:)) - nlist = size(lspill_list(:)) - - if (.not.allocated(keeps) .or. nspill == 0) return - if (.not.allocated(discards)) then - allocate(discards(nspill)) - else if (size(discards) /= nspill) then - deallocate(discards) - allocate(discards(nspill)) - end if - - discards(:) = pack(keeps(1:nlist), lspill_list(1:nlist)) - if (ldestructive) then - if (nkeep > 0) then - allocate(tmp(nkeep)) - tmp(:) = pack(keeps(1:nlist), .not. lspill_list(1:nlist)) - call move_alloc(tmp, keeps) - else - deallocate(keeps) - end if - end if - - return - end subroutine swiftest_util_spill_arr_I8B - - module subroutine swiftest_util_spill_arr_info(keeps, discards, lspill_list, ldestructive) !! author: David A. Minton !! @@ -4410,6 +2998,7 @@ module subroutine swiftest_util_spill_arr_info(keeps, discards, lspill_list, lde nlist = size(lspill_list(:)) if (.not.allocated(keeps) .or. nspill == 0) return + if (size(keeps) < nkeep) return if (.not.allocated(discards)) then allocate(discards(nspill)) else if (size(discards) /= nspill) then @@ -4457,6 +3046,7 @@ module subroutine swiftest_util_spill_arr_kin(keeps, discards, lspill_list, ldes nlist = size(lspill_list(:)) if (.not.allocated(keeps) .or. nspill == 0) return + if (size(keeps) < nkeep) return if (.not.allocated(discards)) then allocate(discards(nspill)) else if (size(discards) /= nspill) then @@ -4479,48 +3069,6 @@ module subroutine swiftest_util_spill_arr_kin(keeps, discards, lspill_list, ldes end subroutine swiftest_util_spill_arr_kin - module subroutine swiftest_util_spill_arr_logical(keeps, discards, lspill_list, ldestructive) - !! author: David A. Minton - !! - !! Performs a spill operation on a single array of logicals - !! This is the inverse of a spill operation - implicit none - ! Arguments - logical, dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - logical, dimension(:), allocatable, intent(inout) :: discards !! Array of discards - logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards - logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or no - ! Internals - integer(I4B) :: nspill, nkeep, nlist - logical, dimension(:), allocatable :: tmp !! Array of values to keep - - nkeep = count(.not.lspill_list(:)) - nspill = count(lspill_list(:)) - nlist = size(lspill_list(:)) - - if (.not.allocated(keeps) .or. nspill == 0) return - if (.not.allocated(discards)) then - allocate(discards(nspill)) - else if (size(discards) /= nspill) then - deallocate(discards) - allocate(discards(nspill)) - end if - - discards(:) = pack(keeps(1:nlist), lspill_list(1:nlist)) - if (ldestructive) then - if (nkeep > 0) then - allocate(tmp(nkeep)) - tmp(:) = pack(keeps(1:nlist), .not. lspill_list(1:nlist)) - call move_alloc(tmp, keeps) - else - deallocate(keeps) - end if - end if - - return - end subroutine swiftest_util_spill_arr_logical - - module subroutine swiftest_util_spill_body(self, discards, lspill_list, ldestructive) !! author: David A. Minton !! @@ -4539,32 +3087,32 @@ module subroutine swiftest_util_spill_body(self, discards, lspill_list, ldestruc !> Spill all the common components associate(keeps => self) - call swiftest_util_spill(keeps%id, discards%id, lspill_list, ldestructive) - call swiftest_util_spill(keeps%info, discards%info, lspill_list, ldestructive) - call swiftest_util_spill(keeps%lmask, discards%lmask, lspill_list, ldestructive) - call swiftest_util_spill(keeps%status, discards%status, lspill_list, ldestructive) - call swiftest_util_spill(keeps%ldiscard, discards%ldiscard, lspill_list, ldestructive) - call swiftest_util_spill(keeps%lcollision, discards%lcollision, lspill_list, ldestructive) - call swiftest_util_spill(keeps%lencounter, discards%lencounter, lspill_list, ldestructive) - call swiftest_util_spill(keeps%mu, discards%mu, lspill_list, ldestructive) - call swiftest_util_spill(keeps%rh, discards%rh, lspill_list, ldestructive) - call swiftest_util_spill(keeps%vh, discards%vh, lspill_list, ldestructive) - call swiftest_util_spill(keeps%rb, discards%rb, lspill_list, ldestructive) - call swiftest_util_spill(keeps%vb, discards%vb, lspill_list, ldestructive) - call swiftest_util_spill(keeps%ah, discards%ah, lspill_list, ldestructive) - call swiftest_util_spill(keeps%aobl, discards%aobl, lspill_list, ldestructive) - call swiftest_util_spill(keeps%agr, discards%agr, lspill_list, ldestructive) - call swiftest_util_spill(keeps%atide, discards%atide, lspill_list, ldestructive) - call swiftest_util_spill(keeps%ir3h, discards%ir3h, lspill_list, ldestructive) - call swiftest_util_spill(keeps%isperi, discards%isperi, lspill_list, ldestructive) - call swiftest_util_spill(keeps%peri, discards%peri, lspill_list, ldestructive) - call swiftest_util_spill(keeps%atp, discards%atp, lspill_list, ldestructive) - call swiftest_util_spill(keeps%a, discards%a, lspill_list, ldestructive) - call swiftest_util_spill(keeps%e, discards%e, lspill_list, ldestructive) - call swiftest_util_spill(keeps%inc, discards%inc, lspill_list, ldestructive) - call swiftest_util_spill(keeps%capom, discards%capom, lspill_list, ldestructive) - call swiftest_util_spill(keeps%omega, discards%omega, lspill_list, ldestructive) - call swiftest_util_spill(keeps%capm, discards%capm, lspill_list, ldestructive) + call util_spill(keeps%id, discards%id, lspill_list, ldestructive) + call util_spill(keeps%info, discards%info, lspill_list, ldestructive) + call util_spill(keeps%lmask, discards%lmask, lspill_list, ldestructive) + call util_spill(keeps%status, discards%status, lspill_list, ldestructive) + call util_spill(keeps%ldiscard, discards%ldiscard, lspill_list, ldestructive) + call util_spill(keeps%lcollision, discards%lcollision, lspill_list, ldestructive) + call util_spill(keeps%lencounter, discards%lencounter, lspill_list, ldestructive) + call util_spill(keeps%mu, discards%mu, lspill_list, ldestructive) + call util_spill(keeps%rh, discards%rh, lspill_list, ldestructive) + call util_spill(keeps%vh, discards%vh, lspill_list, ldestructive) + call util_spill(keeps%rb, discards%rb, lspill_list, ldestructive) + call util_spill(keeps%vb, discards%vb, lspill_list, ldestructive) + call util_spill(keeps%ah, discards%ah, lspill_list, ldestructive) + call util_spill(keeps%aobl, discards%aobl, lspill_list, ldestructive) + call util_spill(keeps%agr, discards%agr, lspill_list, ldestructive) + call util_spill(keeps%atide, discards%atide, lspill_list, ldestructive) + call util_spill(keeps%ir3h, discards%ir3h, lspill_list, ldestructive) + call util_spill(keeps%isperi, discards%isperi, lspill_list, ldestructive) + call util_spill(keeps%peri, discards%peri, lspill_list, ldestructive) + call util_spill(keeps%atp, discards%atp, lspill_list, ldestructive) + call util_spill(keeps%a, discards%a, lspill_list, ldestructive) + call util_spill(keeps%e, discards%e, lspill_list, ldestructive) + call util_spill(keeps%inc, discards%inc, lspill_list, ldestructive) + call util_spill(keeps%capom, discards%capom, lspill_list, ldestructive) + call util_spill(keeps%omega, discards%omega, lspill_list, ldestructive) + call util_spill(keeps%capm, discards%capm, lspill_list, ldestructive) nbody_old = keeps%nbody @@ -4594,24 +3142,24 @@ module subroutine swiftest_util_spill_pl(self, discards, lspill_list, ldestructi select type (discards) ! The standard requires us to select the type of both arguments in order to access all the components class is (swiftest_pl) !> Spill components specific to the massive body class - call swiftest_util_spill(keeps%mass, discards%mass, lspill_list, ldestructive) - call swiftest_util_spill(keeps%Gmass, discards%Gmass, lspill_list, ldestructive) - call swiftest_util_spill(keeps%rhill, discards%rhill, lspill_list, ldestructive) - call swiftest_util_spill(keeps%renc, discards%renc, lspill_list, ldestructive) - call swiftest_util_spill(keeps%radius, discards%radius, lspill_list, ldestructive) - call swiftest_util_spill(keeps%density, discards%density, lspill_list, ldestructive) - call swiftest_util_spill(keeps%rbeg, discards%rbeg, lspill_list, ldestructive) - call swiftest_util_spill(keeps%rend, discards%rend, lspill_list, ldestructive) - call swiftest_util_spill(keeps%vbeg, discards%vbeg, lspill_list, ldestructive) - call swiftest_util_spill(keeps%Ip, discards%Ip, lspill_list, ldestructive) - call swiftest_util_spill(keeps%rot, discards%rot, lspill_list, ldestructive) - call swiftest_util_spill(keeps%k2, discards%k2, lspill_list, ldestructive) - call swiftest_util_spill(keeps%Q, discards%Q, lspill_list, ldestructive) - call swiftest_util_spill(keeps%tlag, discards%tlag, lspill_list, ldestructive) - call swiftest_util_spill(keeps%kin, discards%kin, lspill_list, ldestructive) - call swiftest_util_spill(keeps%lmtiny, discards%lmtiny, lspill_list, ldestructive) - call swiftest_util_spill(keeps%nplenc, discards%nplenc, lspill_list, ldestructive) - call swiftest_util_spill(keeps%ntpenc, discards%ntpenc, lspill_list, ldestructive) + call util_spill(keeps%mass, discards%mass, lspill_list, ldestructive) + call util_spill(keeps%Gmass, discards%Gmass, lspill_list, ldestructive) + call util_spill(keeps%rhill, discards%rhill, lspill_list, ldestructive) + call util_spill(keeps%renc, discards%renc, lspill_list, ldestructive) + call util_spill(keeps%radius, discards%radius, lspill_list, ldestructive) + call util_spill(keeps%density, discards%density, lspill_list, ldestructive) + call util_spill(keeps%rbeg, discards%rbeg, lspill_list, ldestructive) + call util_spill(keeps%rend, discards%rend, lspill_list, ldestructive) + call util_spill(keeps%vbeg, discards%vbeg, lspill_list, ldestructive) + call util_spill(keeps%Ip, discards%Ip, lspill_list, ldestructive) + call util_spill(keeps%rot, discards%rot, lspill_list, ldestructive) + call util_spill(keeps%k2, discards%k2, lspill_list, ldestructive) + call util_spill(keeps%Q, discards%Q, lspill_list, ldestructive) + call util_spill(keeps%tlag, discards%tlag, lspill_list, ldestructive) + call util_spill(keeps%kin, discards%kin, lspill_list, ldestructive) + call util_spill(keeps%lmtiny, discards%lmtiny, lspill_list, ldestructive) + call util_spill(keeps%nplenc, discards%nplenc, lspill_list, ldestructive) + call util_spill(keeps%ntpenc, discards%ntpenc, lspill_list, ldestructive) if (ldestructive .and. allocated(keeps%k_plpl)) deallocate(keeps%k_plpl) @@ -4641,7 +3189,7 @@ module subroutine swiftest_util_spill_tp(self, discards, lspill_list, ldestructi select type(discards) class is (swiftest_tp) !> Spill components specific to the test particle class - call swiftest_util_spill(keeps%nplenc, discards%nplenc, lspill_list, ldestructive) + call util_spill(keeps%nplenc, discards%nplenc, lspill_list, ldestructive) call swiftest_util_spill_body(keeps, discards, lspill_list, ldestructive) class default write(*,*) 'Error! spill method called for incompatible return type on swiftest_tp' @@ -4652,70 +3200,6 @@ module subroutine swiftest_util_spill_tp(self, discards, lspill_list, ldestructi end subroutine swiftest_util_spill_tp - module subroutine swiftest_util_unique_DP(input_array, output_array, index_map) - !! author: David A. Minton - !! - !! Takes an input unsorted integer array and returns a new array of sorted, unique values (DP version) - implicit none - ! Arguments - real(DP), dimension(:), intent(in) :: input_array !! Unsorted input array - real(DP), dimension(:), allocatable, intent(out) :: output_array !! Sorted array of unique values - integer(I4B), dimension(:), allocatable, intent(out) :: index_map !! An array of the same size as input_array that such that any for any index i, output_array(index_map(i)) = input_array(i) - ! Internals - real(DP), dimension(:), allocatable :: unique_array - integer(I4B) :: n - real(DP) :: lo, hi - - allocate(unique_array, mold=input_array) - allocate(index_map(size(input_array))) - lo = minval(input_array) - 1 - hi = maxval(input_array) - - n = 0 - do - n = n + 1 - lo = minval(input_array(:), mask=input_array(:) > lo) - unique_array(n) = lo - where(input_array(:) == lo) index_map(:) = n - if (lo >= hi) exit - enddo - allocate(output_array(n), source=unique_array(1:n)) - - return - end subroutine swiftest_util_unique_DP - - - module subroutine swiftest_util_unique_I4B(input_array, output_array, index_map) - !! author: David A. Minton - !! - !! Takes an input unsorted integer array and returns a new array of sorted, unique values (I4B version) - implicit none - ! Arguments - integer(I4B), dimension(:), intent(in) :: input_array !! Unsorted input array - integer(I4B), dimension(:), allocatable, intent(out) :: output_array !! Sorted array of unique values - integer(I4B), dimension(:), allocatable, intent(out) :: index_map !! An array of the same size as input_array that such that any for any index i, output_array(index_map(i)) = input_array(i) - ! Internals - integer(I4B), dimension(:), allocatable :: unique_array - integer(I4B) :: n, lo, hi - - allocate(unique_array, mold=input_array) - allocate(index_map, mold=input_array) - lo = minval(input_array) - 1 - hi = maxval(input_array) - - n = 0 - do - n = n + 1 - lo = minval(input_array(:), mask=input_array(:) > lo) - unique_array(n) = lo - where(input_array(:) == lo) index_map(:) = n - if (lo >= hi) exit - enddo - allocate(output_array(n), source=unique_array(1:n)) - - return - end subroutine swiftest_util_unique_I4B - module subroutine swiftest_util_valid_id_system(self, param) !! author: David A. Minton @@ -4747,11 +3231,11 @@ module subroutine swiftest_util_valid_id_system(self, param) maxid = maxval(idarr) ! Check to see if the ids are unique - call swiftest_util_unique(idarr, unique_idarr, idmap) + call util_unique(idarr, unique_idarr, idmap) if (size(unique_idarr) == nid) return ! All id values are unique ! Fix any duplicate id values and update the maxid - call swiftest_util_sort(idmap) + call util_sort(idmap) do i = 2, size(idmap) if (idmap(i) == idmap(i-1)) then maxid = maxid + 1 diff --git a/src/symba/symba_module.f90 b/src/symba/symba_module.f90 index efa8dda8f..85e5ca3bc 100644 --- a/src/symba/symba_module.f90 +++ b/src/symba/symba_module.f90 @@ -243,10 +243,12 @@ module subroutine symba_util_dealloc_system(self) class(symba_nbody_system), intent(inout) :: self end subroutine symba_util_dealloc_system - module subroutine symba_util_setup_initialize_system(self, param) + + module subroutine symba_util_setup_initialize_system(self, system_history, param) implicit none - class(symba_nbody_system), intent(inout) :: self !! SyMBA nbody_system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(symba_nbody_system), intent(inout) :: self !! SyMBA nbody_system object + class(swiftest_storage), allocatable, intent(inout) :: system_history !! Stores the system history between output dumps + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters end subroutine symba_util_setup_initialize_system module subroutine symba_util_setup_pl(self, n, param) diff --git a/src/symba/symba_util.f90 b/src/symba/symba_util.f90 index a30c08bac..94b6aa9f5 100644 --- a/src/symba/symba_util.f90 +++ b/src/symba/symba_util.f90 @@ -25,12 +25,10 @@ module subroutine symba_util_append_pl(self, source, lsource_mask) select type(source) class is (symba_pl) - associate(nold => self%nbody, nsrc => source%nbody) - call swiftest_util_append(self%levelg, source%levelg, nold, nsrc, lsource_mask) - call swiftest_util_append(self%levelm, source%levelm, nold, nsrc, lsource_mask) + call util_append(self%levelg, source%levelg, lsource_mask=lsource_mask) + call util_append(self%levelm, source%levelm, lsource_mask=lsource_mask) - call swiftest_util_append_pl(self, source, lsource_mask) ! Note: helio_pl does not have its own append method, so we skip back to the base class - end associate + call swiftest_util_append_pl(self, source, lsource_mask) ! Note: helio_pl does not have its own append method, so we skip back to the base class class default write(*,*) "Invalid object passed to the append method. Source must be of class symba_pl or its descendents!" call base_util_exit(FAILURE) @@ -53,12 +51,10 @@ module subroutine symba_util_append_tp(self, source, lsource_mask) select type(source) class is (symba_tp) - associate(nold => self%nbody, nsrc => source%nbody) - call swiftest_util_append(self%levelg, source%levelg, nold, nsrc, lsource_mask) - call swiftest_util_append(self%levelm, source%levelm, nold, nsrc, lsource_mask) + call util_append(self%levelg, source%levelg, lsource_mask=lsource_mask) + call util_append(self%levelm, source%levelm, lsource_mask=lsource_mask) - call swiftest_util_append_tp(self, source, lsource_mask) ! Note: helio_tp does not have its own append method, so we skip back to the base class - end associate + call swiftest_util_append_tp(self, source, lsource_mask) ! Note: helio_tp does not have its own append method, so we skip back to the base class class default write(*,*) "Invalid object passed to the append method. Source must be of class symba_tp or its descendents!" call base_util_exit(FAILURE) @@ -134,8 +130,8 @@ module subroutine symba_util_fill_pl(self, inserts, lfill_list) associate(keeps => self) select type(inserts) class is (symba_pl) - call swiftest_util_fill(keeps%levelg, inserts%levelg, lfill_list) - call swiftest_util_fill(keeps%levelm, inserts%levelm, lfill_list) + call util_fill(keeps%levelg, inserts%levelg, lfill_list) + call util_fill(keeps%levelm, inserts%levelm, lfill_list) call swiftest_util_fill_pl(keeps, inserts, lfill_list) ! Note: helio_pl does not have its own fill method, so we skip back to the base class class default @@ -163,9 +159,9 @@ module subroutine symba_util_fill_tp(self, inserts, lfill_list) associate(keeps => self) select type(inserts) class is (symba_tp) - call swiftest_util_fill(keeps%nplenc, inserts%nplenc, lfill_list) - call swiftest_util_fill(keeps%levelg, inserts%levelg, lfill_list) - call swiftest_util_fill(keeps%levelm, inserts%levelm, lfill_list) + call util_fill(keeps%nplenc, inserts%nplenc, lfill_list) + call util_fill(keeps%levelg, inserts%levelg, lfill_list) + call util_fill(keeps%levelm, inserts%levelm, lfill_list) call swiftest_util_fill_tp(keeps, inserts, lfill_list) ! Note: helio_tp does not have its own fill method, so we skip back to the base class class default @@ -223,8 +219,8 @@ module subroutine symba_util_resize_pl(self, nnew) class(symba_pl), intent(inout) :: self !! SyMBA massive body object integer(I4B), intent(in) :: nnew !! New size neded - call swiftest_util_resize(self%levelg, nnew) - call swiftest_util_resize(self%levelm, nnew) + call util_resize(self%levelg, nnew) + call util_resize(self%levelm, nnew) call swiftest_util_resize_pl(self, nnew) @@ -240,8 +236,8 @@ module subroutine symba_util_resize_tp(self, nnew) class(symba_tp), intent(inout) :: self !! SyMBA test particle object integer(I4B), intent(in) :: nnew !! New size neded - call swiftest_util_resize(self%levelg, nnew) - call swiftest_util_resize(self%levelm, nnew) + call util_resize(self%levelg, nnew) + call util_resize(self%levelm, nnew) call swiftest_util_resize_tp(self, nnew) @@ -273,7 +269,7 @@ module subroutine symba_util_set_renc(self, scale) end subroutine symba_util_set_renc - module subroutine symba_util_setup_initialize_system(self, param) + module subroutine symba_util_setup_initialize_system(self, system_history, param) !! author: David A. Minton !! !! Initialize an SyMBA nbody system from files and sets up the planetocentric structures. @@ -281,8 +277,9 @@ module subroutine symba_util_setup_initialize_system(self, param) !! implicit none ! Arguments - class(symba_nbody_system), intent(inout) :: self !! SyMBA nbody_system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(symba_nbody_system), intent(inout) :: self !! SyMBA nbody_system object + class(swiftest_storage), allocatable, intent(inout) :: system_history !! Stores the system history between output dumps + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters ! Internals type(encounter_storage) :: encounter_history type(collision_storage) :: collision_history @@ -291,7 +288,7 @@ module subroutine symba_util_setup_initialize_system(self, param) call collision_history%setup(4096) ! Call parent method associate(nbody_system => self) - call helio_util_setup_initialize_system(nbody_system, param) + call helio_util_setup_initialize_system(nbody_system, system_history, param) call nbody_system%pltp_encounter%setup(0_I8B) call nbody_system%plpl_encounter%setup(0_I8B) call nbody_system%plpl_collision%setup(0_I8B) @@ -422,9 +419,9 @@ module subroutine symba_util_sort_pl(self, sortby, ascending) associate(pl => self, npl => self%nbody) select case(sortby) case("levelg") - call swiftest_util_sort(direction * pl%levelg(1:npl), ind) + call util_sort(direction * pl%levelg(1:npl), ind) case("levelm") - call swiftest_util_sort(direction * pl%levelm(1:npl), ind) + call util_sort(direction * pl%levelm(1:npl), ind) case default ! Look for components in the parent class call swiftest_util_sort_pl(pl, sortby, ascending) @@ -463,11 +460,11 @@ module subroutine symba_util_sort_tp(self, sortby, ascending) associate(tp => self, ntp => self%nbody) select case(sortby) case("nplenc") - call swiftest_util_sort(direction * tp%nplenc(1:ntp), ind) + call util_sort(direction * tp%nplenc(1:ntp), ind) case("levelg") - call swiftest_util_sort(direction * tp%levelg(1:ntp), ind) + call util_sort(direction * tp%levelg(1:ntp), ind) case("levelm") - call swiftest_util_sort(direction * tp%levelm(1:ntp), ind) + call util_sort(direction * tp%levelm(1:ntp), ind) case default ! Look for components in the parent class call swiftest_util_sort_tp(tp, sortby, ascending) return @@ -491,8 +488,8 @@ module subroutine symba_util_sort_rearrange_pl(self, ind) integer(I4B), dimension(:), intent(in) :: ind !! Index array used to restructure the body (should contain all 1:n index values in the desired order) associate(pl => self, npl => self%nbody) - call swiftest_util_sort_rearrange(pl%levelg, ind, npl) - call swiftest_util_sort_rearrange(pl%levelm, ind, npl) + call util_sort_rearrange(pl%levelg, ind, npl) + call util_sort_rearrange(pl%levelm, ind, npl) call swiftest_util_sort_rearrange_pl(pl,ind) end associate @@ -511,9 +508,9 @@ module subroutine symba_util_sort_rearrange_tp(self, ind) integer(I4B), dimension(:), intent(in) :: ind !! Index array used to restructure the body (should contain all 1:n index values in the desired order) associate(tp => self, ntp => self%nbody) - call swiftest_util_sort_rearrange(tp%nplenc, ind, ntp) - call swiftest_util_sort_rearrange(tp%levelg, ind, ntp) - call swiftest_util_sort_rearrange(tp%levelm, ind, ntp) + call util_sort_rearrange(tp%nplenc, ind, ntp) + call util_sort_rearrange(tp%levelg, ind, ntp) + call util_sort_rearrange(tp%levelm, ind, ntp) call swiftest_util_sort_rearrange_tp(tp,ind) end associate @@ -539,8 +536,8 @@ module subroutine symba_util_spill_pl(self, discards, lspill_list, ldestructive) associate(keeps => self) select type(discards) class is (symba_pl) - call swiftest_util_spill(keeps%levelg, discards%levelg, lspill_list, ldestructive) - call swiftest_util_spill(keeps%levelm, discards%levelm, lspill_list, ldestructive) + call util_spill(keeps%levelg, discards%levelg, lspill_list, ldestructive) + call util_spill(keeps%levelm, discards%levelm, lspill_list, ldestructive) call swiftest_util_spill_pl(keeps, discards, lspill_list, ldestructive) class default @@ -570,9 +567,9 @@ module subroutine symba_util_spill_tp(self, discards, lspill_list, ldestructive) associate(keeps => self) select type(discards) class is (symba_tp) - call swiftest_util_spill(keeps%nplenc, discards%nplenc, lspill_list, ldestructive) - call swiftest_util_spill(keeps%levelg, discards%levelg, lspill_list, ldestructive) - call swiftest_util_spill(keeps%levelm, discards%levelm, lspill_list, ldestructive) + call util_spill(keeps%nplenc, discards%nplenc, lspill_list, ldestructive) + call util_spill(keeps%levelg, discards%levelg, lspill_list, ldestructive) + call util_spill(keeps%levelm, discards%levelm, lspill_list, ldestructive) call swiftest_util_spill_tp(keeps, discards, lspill_list, ldestructive) class default diff --git a/src/whm/whm_coarray.f90 b/src/whm/whm_coarray.f90 new file mode 100644 index 000000000..5a8de4c32 --- /dev/null +++ b/src/whm/whm_coarray.f90 @@ -0,0 +1,34 @@ +!! Copyright 2023 - David Minton +!! This file is part of Swiftest. +!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License +!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. +!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty +!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. +!! You should have received a copy of the GNU General Public License along with Swiftest. +!! If not, see: https://www.gnu.org/licenses. + +submodule (whm) s_whm_coarray +use coarray +use swiftest +contains + + module subroutine whm_coarray_coclone_pl(self) + !! author: David A. Minton + !! + !! Broadcasts the image 1 object to all other images in a coarray + implicit none + ! Arguments + class(whm_pl),intent(inout),codimension[*] :: self !! WHM pl object + + call coclone(self%eta) + call coclone(self%xj) + call coclone(self%vj) + call coclone(self%muj) + call coclone(self%ir3j) + + call swiftest_coarray_coclone_pl(self) + + return + end subroutine whm_coarray_coclone_pl + +end submodule s_whm_coarray \ No newline at end of file diff --git a/src/whm/whm_module.f90 b/src/whm/whm_module.f90 index d2d10f971..38e73f190 100644 --- a/src/whm/whm_module.f90 +++ b/src/whm/whm_module.f90 @@ -48,10 +48,13 @@ module whm procedure :: set_mu => whm_util_set_mu_eta_pl !! Sets the Jacobi mass value for all massive bodies. procedure :: sort => whm_util_sort_pl !! Sort a WHM massive body object in-place. procedure :: rearrange => whm_util_sort_rearrange_pl !! Rearranges the order of array elements of body based on an input index array. Used in sorting methods - procedure :: spill => whm_util_spill_pl !!"Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) - procedure :: setup => whm_util_setup_pl !! Constructor method - Allocates space for the input number of bodiess + procedure :: spill => whm_util_spill_pl !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) + procedure :: setup => whm_util_setup_pl !! Constructor method - Allocates space for the input number of bodiess procedure :: step => whm_step_pl !! Steps the body forward one stepsize - final :: whm_final_pl !! Finalizes the WHM massive body object - deallocates all allocatables + final :: whm_final_pl !! Finalizes the WHM massive body object - deallocates all allocatables +#ifdef COARRAY + procedure :: coclone => whm_coarray_coclone_pl !! Clones the image 1 body object to all other images in the coarray structure. +#endif end type whm_pl @@ -180,10 +183,11 @@ module subroutine whm_util_setup_pl(self, n, param) class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters end subroutine whm_util_setup_pl - module subroutine whm_util_setup_initialize_system(self, param) + module subroutine whm_util_setup_initialize_system(self, system_history, param) implicit none - class(whm_nbody_system), intent(inout) :: self !! WHM nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(whm_nbody_system), intent(inout) :: self !! WHM nbody system object + class(swiftest_storage), allocatable, intent(inout) :: system_history !! Stores the system history between output dumps + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters end subroutine whm_util_setup_initialize_system module subroutine whm_step_pl(self, nbody_system, param, t, dt) @@ -270,6 +274,15 @@ module subroutine whm_util_sort_rearrange_pl(self, ind) end subroutine whm_util_sort_rearrange_pl end interface +#ifdef COARRAY + interface + module subroutine whm_coarray_coclone_pl(self) + implicit none + class(whm_pl),intent(inout),codimension[*] :: self !! WHM pl object + end subroutine whm_coarray_coclone_pl + end interface +#endif + contains subroutine whm_final_pl(self) diff --git a/src/whm/whm_util.f90 b/src/whm/whm_util.f90 index 751e97d2a..09fa59d76 100644 --- a/src/whm/whm_util.f90 +++ b/src/whm/whm_util.f90 @@ -24,15 +24,13 @@ module subroutine whm_util_append_pl(self, source, lsource_mask) select type(source) class is (whm_pl) - associate(nold => self%nbody, nsrc => source%nbody) - call swiftest_util_append(self%eta, source%eta, nold, nsrc, lsource_mask) - call swiftest_util_append(self%muj, source%muj, nold, nsrc, lsource_mask) - call swiftest_util_append(self%ir3j, source%ir3j, nold, nsrc, lsource_mask) - call swiftest_util_append(self%xj, source%xj, nold, nsrc, lsource_mask) - call swiftest_util_append(self%vj, source%vj, nold, nsrc, lsource_mask) - - call swiftest_util_append_pl(self, source, lsource_mask) - end associate + call util_append(self%eta, source%eta, lsource_mask=lsource_mask) + call util_append(self%muj, source%muj, lsource_mask=lsource_mask) + call util_append(self%ir3j, source%ir3j, lsource_mask=lsource_mask) + call util_append(self%xj, source%xj, lsource_mask=lsource_mask) + call util_append(self%vj, source%vj, lsource_mask=lsource_mask) + + call swiftest_util_append_pl(self, source, lsource_mask) class default write(*,*) "Invalid object passed to the append method. Source must be of class whm_pl or its descendents" call base_util_exit(FAILURE) @@ -78,11 +76,11 @@ module subroutine whm_util_fill_pl(self, inserts, lfill_list) associate(keeps => self) select type(inserts) class is (whm_pl) - call swiftest_util_fill(keeps%eta, inserts%eta, lfill_list) - call swiftest_util_fill(keeps%muj, inserts%muj, lfill_list) - call swiftest_util_fill(keeps%ir3j, inserts%ir3j, lfill_list) - call swiftest_util_fill(keeps%xj, inserts%xj, lfill_list) - call swiftest_util_fill(keeps%vj, inserts%vj, lfill_list) + call util_fill(keeps%eta, inserts%eta, lfill_list) + call util_fill(keeps%muj, inserts%muj, lfill_list) + call util_fill(keeps%ir3j, inserts%ir3j, lfill_list) + call util_fill(keeps%xj, inserts%xj, lfill_list) + call util_fill(keeps%vj, inserts%vj, lfill_list) call swiftest_util_fill_pl(keeps, inserts, lfill_list) class default @@ -104,11 +102,11 @@ module subroutine whm_util_resize_pl(self, nnew) class(whm_pl), intent(inout) :: self !! WHM massive body object integer(I4B), intent(in) :: nnew !! New size neded - call swiftest_util_resize(self%eta, nnew) - call swiftest_util_resize(self%xj, nnew) - call swiftest_util_resize(self%vj, nnew) - call swiftest_util_resize(self%muj, nnew) - call swiftest_util_resize(self%ir3j, nnew) + call util_resize(self%eta, nnew) + call util_resize(self%xj, nnew) + call util_resize(self%vj, nnew) + call util_resize(self%muj, nnew) + call util_resize(self%ir3j, nnew) call swiftest_util_resize_pl(self, nnew) @@ -200,17 +198,18 @@ module subroutine whm_util_set_mu_eta_pl(self, cb) end subroutine whm_util_set_mu_eta_pl - module subroutine whm_util_setup_initialize_system(self, param) + module subroutine whm_util_setup_initialize_system(self, system_history, param) !! author: David A. Minton !! !! Initialize a WHM nbody system from files !! implicit none ! Arguments - class(whm_nbody_system), intent(inout) :: self !! WHM nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(whm_nbody_system), intent(inout) :: self !! WHM nbody system object + class(swiftest_storage), allocatable, intent(inout) :: system_history !! Stores the system history between output dumps + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - call swiftest_util_setup_initialize_system(self, param) + call swiftest_util_setup_initialize_system(self, system_history, param) ! First we need to make sure that the massive bodies are sorted by heliocentric distance before computing jacobies call swiftest_util_set_ir3h(self%pl) call self%pl%sort("ir3h", ascending=.false.) @@ -254,11 +253,11 @@ module subroutine whm_util_sort_pl(self, sortby, ascending) associate(pl => self, npl => self%nbody) select case(sortby) case("eta") - call swiftest_util_sort(direction * pl%eta(1:npl), ind) + call util_sort(direction * pl%eta(1:npl), ind) case("muj") - call swiftest_util_sort(direction * pl%muj(1:npl), ind) + call util_sort(direction * pl%muj(1:npl), ind) case("ir3j") - call swiftest_util_sort(direction * pl%ir3j(1:npl), ind) + call util_sort(direction * pl%ir3j(1:npl), ind) case("xj", "vj") write(*,*) 'Cannot sort by ' // trim(adjustl(sortby)) // '. Component not sortable!' case default @@ -286,11 +285,11 @@ module subroutine whm_util_sort_rearrange_pl(self, ind) if (self%nbody == 0) return associate(pl => self, npl => self%nbody) - call swiftest_util_sort_rearrange(pl%eta, ind, npl) - call swiftest_util_sort_rearrange(pl%xj, ind, npl) - call swiftest_util_sort_rearrange(pl%vj, ind, npl) - call swiftest_util_sort_rearrange(pl%muj, ind, npl) - call swiftest_util_sort_rearrange(pl%ir3j, ind, npl) + call util_sort_rearrange(pl%eta, ind, npl) + call util_sort_rearrange(pl%xj, ind, npl) + call util_sort_rearrange(pl%vj, ind, npl) + call util_sort_rearrange(pl%muj, ind, npl) + call util_sort_rearrange(pl%ir3j, ind, npl) call swiftest_util_sort_rearrange_pl(pl,ind) end associate @@ -315,11 +314,11 @@ module subroutine whm_util_spill_pl(self, discards, lspill_list, ldestructive) associate(keeps => self) select type(discards) class is (whm_pl) - call swiftest_util_spill(keeps%eta, discards%eta, lspill_list, ldestructive) - call swiftest_util_spill(keeps%muj, discards%muj, lspill_list, ldestructive) - call swiftest_util_spill(keeps%ir3j, discards%ir3j, lspill_list, ldestructive) - call swiftest_util_spill(keeps%xj, discards%xj, lspill_list, ldestructive) - call swiftest_util_spill(keeps%vj, discards%vj, lspill_list, ldestructive) + call util_spill(keeps%eta, discards%eta, lspill_list, ldestructive) + call util_spill(keeps%muj, discards%muj, lspill_list, ldestructive) + call util_spill(keeps%ir3j, discards%ir3j, lspill_list, ldestructive) + call util_spill(keeps%xj, discards%xj, lspill_list, ldestructive) + call util_spill(keeps%vj, discards%vj, lspill_list, ldestructive) call swiftest_util_spill_pl(keeps, discards, lspill_list, ldestructive) class default