diff --git a/src/discard/discard.f90 b/src/discard/discard.f90 index 292e52c38..0c84c9e88 100644 --- a/src/discard/discard.f90 +++ b/src/discard/discard.f90 @@ -69,7 +69,7 @@ module subroutine discard_tp(self, system, param) end if if (param%qmin >= 0.0_DP .and. ntp > 0) call discard_peri_tp(tp, system, param) if (param%lclose .and. ntp > 0) call discard_pl_tp(tp, system, param) - if (any(tp%ldiscard)) call tp%spill(system%tp_discards, tp%ldiscard) + if (any(tp%ldiscard)) call tp%spill(system%tp_discards, tp%ldiscard, ldestructive=.true.) end associate return diff --git a/src/modules/rmvs_classes.f90 b/src/modules/rmvs_classes.f90 index 64a0a5875..4c3bac64f 100644 --- a/src/modules/rmvs_classes.f90 +++ b/src/modules/rmvs_classes.f90 @@ -53,7 +53,7 @@ module rmvs_classes !! RMVS test particle class type, extends(whm_tp) :: rmvs_tp !! Note to developers: If you add componenets to this class, be sure to update methods and subroutines that traverse the - !! component list, such as rmvs_setup_tp and rmvs_util_copy_spill_tp + !! component list, such as rmvs_setup_tp and rmvs_util_spill_tp ! encounter steps) logical, dimension(:), allocatable :: lperi !! planetocentric pericenter passage flag (persistent for a full rmvs time step) over a full RMVS time step) integer(I4B), dimension(:), allocatable :: plperP !! index of planet associated with pericenter distance peri (persistent over a full RMVS time step) @@ -71,10 +71,10 @@ module rmvs_classes procedure :: accel => rmvs_kick_getacch_tp !! Calculates either the standard or modified version of the acceleration depending if the !! if the test particle is undergoing a close encounter or not procedure :: setup => rmvs_setup_tp !! Constructor method - Allocates space for number of particles - procedure :: fill => rmvs_util_copy_fill_tp !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) + procedure :: fill => rmvs_util_fill_tp !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) procedure :: sort => rmvs_util_sort_tp !! Sorts body arrays by a sortable componen 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_copy_spill_tp !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) + procedure :: spill => rmvs_util_spill_tp !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) end type rmvs_tp !******************************************************************************************************************************** @@ -94,8 +94,8 @@ module rmvs_classes procedure :: setup => rmvs_setup_pl !! Constructor method - Allocates space for number of particles 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 :: fill => rmvs_util_copy_fill_pl !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) - procedure :: spill => rmvs_util_copy_spill_pl !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) + procedure :: fill => rmvs_util_fill_pl !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) + procedure :: spill => rmvs_util_spill_pl !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) end type rmvs_pl interface @@ -154,21 +154,21 @@ module subroutine rmvs_setup_tp(self, n, param) class(swiftest_parameters), intent(in) :: param !! Current run configuration parametere end subroutine rmvs_setup_tp - module subroutine rmvs_util_copy_fill_pl(self, inserts, lfill_list) + module subroutine rmvs_util_fill_pl(self, inserts, lfill_list) use swiftest_classes, only : swiftest_body implicit none class(rmvs_pl), intent(inout) :: self !! RMVS massive body object class(swiftest_body), intent(in) :: inserts !! Inserted object logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - end subroutine rmvs_util_copy_fill_pl + end subroutine rmvs_util_fill_pl - module subroutine rmvs_util_copy_fill_tp(self, inserts, lfill_list) + module subroutine rmvs_util_fill_tp(self, inserts, lfill_list) use swiftest_classes, only : swiftest_body implicit none class(rmvs_tp), intent(inout) :: self !! RMVS massive body object class(swiftest_body), intent(in) :: inserts !! Inserted object logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - end subroutine rmvs_util_copy_fill_tp + end subroutine rmvs_util_fill_tp module subroutine rmvs_util_sort_pl(self, sortby, ascending) implicit none @@ -196,21 +196,23 @@ module subroutine rmvs_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) end subroutine rmvs_util_sort_rearrange_tp - module subroutine rmvs_util_copy_spill_pl(self, discards, lspill_list) + module subroutine rmvs_util_spill_pl(self, discards, lspill_list, ldestructive) use swiftest_classes, only : swiftest_body implicit none - class(rmvs_pl), intent(inout) :: self !! RMVS massive body object - class(swiftest_body), intent(inout) :: discards !! Discarded object - logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards - end subroutine rmvs_util_copy_spill_pl + class(rmvs_pl), intent(inout) :: self !! RMVS massive body object + class(swiftest_body), intent(inout) :: discards !! Discarded object + 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 rmvs_util_spill_pl - module subroutine rmvs_util_copy_spill_tp(self, discards, lspill_list) + module subroutine rmvs_util_spill_tp(self, discards, lspill_list, ldestructive) use swiftest_classes, only : swiftest_body implicit none - class(rmvs_tp), intent(inout) :: self !! RMVS test particle object - class(swiftest_body), intent(inout) :: discards !! Discarded object - logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards - end subroutine rmvs_util_copy_spill_tp + class(rmvs_tp), intent(inout) :: self !! RMVS test particle object + class(swiftest_body), intent(inout) :: discards !! Discarded object + 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 rmvs_util_spill_tp module subroutine rmvs_step_system(self, param, t, dt) use swiftest_classes, only : swiftest_parameters diff --git a/src/modules/swiftest_classes.f90 b/src/modules/swiftest_classes.f90 index c8d05850f..be342756e 100644 --- a/src/modules/swiftest_classes.f90 +++ b/src/modules/swiftest_classes.f90 @@ -145,7 +145,7 @@ module swiftest_classes real(DP), dimension(:), allocatable :: mu !! G * (Mcb + [m]) logical, dimension(:), allocatable :: lmask !! Logical mask used to select a subset of bodies when performing certain operations (drift, kick, accel, etc.) !! Note to developers: If you add components to this class, be sure to update methods and subroutines that traverse the - !! component list, such as setup_body and util_copy_spill + !! component list, such as setup_body and util_spill contains procedure(abstract_discard_body), deferred :: discard procedure(abstract_kick_body), deferred :: kick @@ -166,12 +166,12 @@ module swiftest_classes procedure :: accel_user => user_kick_getacch_body !! Add user-supplied heliocentric accelerations to planets procedure :: append => util_append_body !! Appends elements from one structure to another procedure :: copy_into => util_copy_into_body !! Copies elements from one Swiftest body object to another. - procedure :: fill => util_copy_fill_body !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) + procedure :: fill => util_fill_body !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) procedure :: resize => 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 => util_set_ir3h !! Sets the inverse heliocentric radius term (1/rh**3) procedure :: sort => util_sort_body !! Sorts body arrays by a sortable componen procedure :: rearrange => util_sort_rearrange_body !! Rearranges the order of array elements of body based on an input index array. Used in sorting methods - procedure :: spill => util_copy_spill_body !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) + procedure :: spill => util_spill_body !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) end type swiftest_body !******************************************************************************************************************************** @@ -196,7 +196,7 @@ module swiftest_classes integer(I4B), dimension(:,:), allocatable :: k_plpl !! Index array used to convert flattened the body-body comparison upper triangular matrix integer(I8B) :: nplpl !! Number of body-body comparisons in the flattened upper triangular matrix !! Note to developers: If you add components to this class, be sure to update methods and subroutines that traverse the - !! component list, such as setup_pl and util_copy_spill_pl + !! component list, such as setup_pl and util_spill_pl contains ! Massive body-specific concrete methods ! These are concrete because they are the same implemenation for all integrators @@ -208,13 +208,13 @@ module swiftest_classes procedure :: accel_tides => tides_kick_getacch_pl !! Compute the accelerations of bodies due to tidal interactions with the central body procedure :: h2b => util_coord_h2b_pl !! Convert massive bodies from heliocentric to barycentric coordinates (position and velocity) procedure :: b2h => util_coord_b2h_pl !! Convert massive bodies from barycentric to heliocentric coordinates (position and velocity) - procedure :: fill => util_copy_fill_pl !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) + procedure :: fill => util_fill_pl !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) procedure :: set_beg_end => util_set_beg_end_pl !! Sets the beginning and ending positions and velocities of planets. procedure :: set_mu => util_set_mu_pl !! Method used to construct the vectorized form of the central body mass procedure :: set_rhill => util_set_rhill !! Calculates the Hill's radii for each body procedure :: sort => util_sort_pl !! Sorts body arrays by a sortable component procedure :: rearrange => util_sort_rearrange_pl !! Rearranges the order of array elements of body based on an input index array. Used in sorting methods - procedure :: spill => util_copy_spill_pl !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) + procedure :: spill => util_spill_pl !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) end type swiftest_pl !******************************************************************************************************************************** @@ -227,7 +227,7 @@ module swiftest_classes real(DP), dimension(:), allocatable :: peri !! Perihelion distance real(DP), dimension(:), allocatable :: atp !! Semimajor axis following perihelion passage !! Note to developers: If you add components to this class, be sure to update methods and subroutines that traverse the - !! component list, such as setup_tp and util_copy_spill_tp + !! component list, such as setup_tp and util_spill_tp contains ! Test particle-specific concrete methods ! These are concrete because they are the same implemenation for all integrators @@ -237,12 +237,12 @@ module swiftest_classes procedure :: setup => setup_tp !! A base constructor that sets the number of bodies and procedure :: h2b => util_coord_h2b_tp !! Convert test particles from heliocentric to barycentric coordinates (position and velocity) procedure :: b2h => util_coord_b2h_tp !! Convert test particles from barycentric to heliocentric coordinates (position and velocity) - procedure :: fill => util_copy_fill_tp !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) + procedure :: fill => util_fill_tp !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) procedure :: get_peri => util_peri_tp !! Determine system pericenter passages for test particles procedure :: set_mu => util_set_mu_tp !! Method used to construct the vectorized form of the central body mass procedure :: sort => util_sort_tp !! Sorts body arrays by a sortable component procedure :: rearrange => util_sort_rearrange_tp !! Rearranges the order of array elements of body based on an input index array. Used in sorting methods - procedure :: spill => util_copy_spill_tp !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) + procedure :: spill => util_spill_tp !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) end type swiftest_tp !******************************************************************************************************************************** @@ -781,61 +781,61 @@ module subroutine util_exit(code) integer(I4B), intent(in) :: code !! Failure exit code end subroutine util_exit - module subroutine util_copy_fill_body(self, inserts, lfill_list) + module subroutine util_fill_body(self, inserts, lfill_list) implicit none class(swiftest_body), intent(inout) :: self !! Swiftest body object class(swiftest_body), intent(in) :: inserts !! Swiftest body object to be inserted logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - end subroutine util_copy_fill_body + end subroutine util_fill_body - module subroutine util_copy_fill_pl(self, inserts, lfill_list) + module subroutine util_fill_pl(self, inserts, lfill_list) implicit none class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object class(swiftest_body), intent(in) :: inserts !! Swiftest body object to be inserted logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - end subroutine util_copy_fill_pl + end subroutine util_fill_pl - module subroutine util_copy_fill_tp(self, inserts, lfill_list) + module subroutine util_fill_tp(self, inserts, lfill_list) implicit none class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object class(swiftest_body), intent(in) :: inserts !! Swiftest body object to be inserted logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - end subroutine util_copy_fill_tp + end subroutine util_fill_tp end interface interface util_fill module subroutine 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 arrays to insert into 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 util_fill_arr_char_string module subroutine 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 arrays to insert into 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 util_fill_arr_DP module subroutine 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 arrays to insert into 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 util_fill_arr_DPvec module subroutine 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 arrays to insert into 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 util_fill_arr_I4B module subroutine 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 arrays to insert into 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 util_fill_arr_logical end interface @@ -972,27 +972,74 @@ module subroutine util_sort_tp(self, sortby, ascending) 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 end subroutine util_sort_tp - - module subroutine util_copy_spill_body(self, discards, lspill_list) + end interface + + interface util_spill + module subroutine 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 util_spill_arr_char_string + + module subroutine 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 util_spill_arr_DP + + module subroutine 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 util_spill_arr_DPvec + + module subroutine 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 util_spill_arr_I4B + + module subroutine 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 util_spill_arr_logical + end interface + + interface + module subroutine util_spill_body(self, discards, lspill_list, ldestructive) implicit none class(swiftest_body), intent(inout) :: self !! Swiftest body object class(swiftest_body), intent(inout) :: discards !! Discarded object logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards - end subroutine util_copy_spill_body + logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not + end subroutine util_spill_body - module subroutine util_copy_spill_pl(self, discards, lspill_list) + module subroutine util_spill_pl(self, discards, lspill_list, ldestructive) implicit none class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object class(swiftest_body), intent(inout) :: discards !! Discarded object logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards - end subroutine util_copy_spill_pl + logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not + end subroutine util_spill_pl - module subroutine util_copy_spill_tp(self, discards, lspill_list) + module subroutine util_spill_tp(self, discards, lspill_list, ldestructive) implicit none class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object class(swiftest_body), intent(inout) :: discards !! Discarded object logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards - end subroutine util_copy_spill_tp + logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not + end subroutine util_spill_tp module subroutine util_valid(pl, tp) implicit none diff --git a/src/modules/symba_classes.f90 b/src/modules/symba_classes.f90 index 0080b1e07..f0cf9e00d 100644 --- a/src/modules/symba_classes.f90 +++ b/src/modules/symba_classes.f90 @@ -92,10 +92,10 @@ module symba_classes procedure :: encounter_check => symba_encounter_check_pl !! Checks if massive bodies are going through close encounters with each other procedure :: accel => symba_kick_getacch_pl !! Compute heliocentric accelerations of massive bodies procedure :: setup => symba_setup_pl !! Constructor method - Allocates space for number of particle - procedure :: fill => symba_util_copy_fill_pl !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) + procedure :: fill => symba_util_fill_pl !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) procedure :: sort => symba_util_sort_pl !! Sorts body arrays by a sortable componen procedure :: rearrange => symba_util_sort_rearrange_pl !! Rearranges the order of array elements of body based on an input index array. Used in sorting methods - procedure :: spill => symba_util_copy_spill_pl !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) + procedure :: spill => symba_util_spill_pl !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) end type symba_pl !******************************************************************************************************************************** @@ -111,10 +111,10 @@ module symba_classes procedure :: encounter_check => symba_encounter_check_tp !! Checks if any test particles are undergoing a close encounter with a massive body procedure :: accel => symba_kick_getacch_tp !! Compute heliocentric accelerations of test particles procedure :: setup => symba_setup_tp !! Constructor method - Allocates space for number of particle - procedure :: fill => symba_util_copy_fill_tp !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) + procedure :: fill => symba_util_fill_tp !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) procedure :: sort => symba_util_sort_tp !! Sorts body arrays by a sortable componen procedure :: rearrange => symba_util_sort_rearrange_tp !! Rearranges the order of array elements of body based on an input index array. Used in sorting methods - procedure :: spill => symba_util_copy_spill_tp !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) + procedure :: spill => symba_util_spill_tp !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) end type symba_tp !******************************************************************************************************************************** @@ -418,21 +418,21 @@ module subroutine symba_step_reset_system(self) class(symba_nbody_system), intent(inout) :: self !! SyMBA nbody system object end subroutine symba_step_reset_system - module subroutine symba_util_copy_fill_pl(self, inserts, lfill_list) + module subroutine symba_util_fill_pl(self, inserts, lfill_list) use swiftest_classes, only : swiftest_body implicit none class(symba_pl), intent(inout) :: self !! SyMBA massive body object class(swiftest_body), intent(in) :: inserts !! Inserted object logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - end subroutine symba_util_copy_fill_pl + end subroutine symba_util_fill_pl - module subroutine symba_util_copy_fill_tp(self, inserts, lfill_list) + module subroutine symba_util_fill_tp(self, inserts, lfill_list) use swiftest_classes, only : swiftest_body implicit none class(symba_tp), intent(inout) :: self !! SyMBA test particle object class(swiftest_body), intent(in) :: inserts !! Inserted object logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - end subroutine symba_util_copy_fill_tp + end subroutine symba_util_fill_tp module subroutine symba_util_copy_pltpenc(self, source) implicit none @@ -452,21 +452,23 @@ module subroutine symba_util_resize_pltpenc(self, nrequested) integer(I4B), intent(in) :: nrequested !! New size of list needed end subroutine symba_util_resize_pltpenc - module subroutine symba_util_copy_spill_pl(self, discards, lspill_list) + module subroutine symba_util_spill_pl(self, discards, lspill_list, ldestructive) use swiftest_classes, only : swiftest_body implicit none - class(symba_pl), intent(inout) :: self !! SyMBA massive body object - class(swiftest_body), intent(inout) :: discards !! Discarded object - logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards - end subroutine symba_util_copy_spill_pl + class(symba_pl), intent(inout) :: self !! SyMBA massive body object + class(swiftest_body), intent(inout) :: discards !! Discarded object + 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 symba_util_spill_pl - module subroutine symba_util_copy_spill_tp(self, discards, lspill_list) + module subroutine symba_util_spill_tp(self, discards, lspill_list, ldestructive) use swiftest_classes, only : swiftest_body implicit none - class(symba_tp), intent(inout) :: self !! SyMBA test particle object - class(swiftest_body), intent(inout) :: discards !! Discarded object - logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards - end subroutine symba_util_copy_spill_tp + class(symba_tp), intent(inout) :: self !! SyMBA test particle object + class(swiftest_body), intent(inout) :: discards !! Discarded object + 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 symba_util_spill_tp module subroutine symba_util_sort_pl(self, sortby, ascending) implicit none diff --git a/src/modules/whm_classes.f90 b/src/modules/whm_classes.f90 index 4dd7f646a..626c0a974 100644 --- a/src/modules/whm_classes.f90 +++ b/src/modules/whm_classes.f90 @@ -28,13 +28,13 @@ module whm_classes real(DP), dimension(:), allocatable :: muj !! Jacobi mu: GMcb * eta(i) / eta(i - 1) real(DP), dimension(:), allocatable :: ir3j !! Third term of heliocentric acceleration !! Note to developers: If you add componenets to this class, be sure to update methods and subroutines that traverse the - !! component list, such as whm_setup_pl and whm_util_copy_spill_pl + !! component list, such as whm_setup_pl and whm_util_spill_pl contains procedure :: h2j => whm_coord_h2j_pl !! Convert position and velcoity vectors from heliocentric to Jacobi coordinates procedure :: j2h => whm_coord_j2h_pl !! Convert position and velcoity vectors from Jacobi to helliocentric coordinates procedure :: vh2vj => whm_coord_vh2vj_pl !! Convert velocity vectors from heliocentric to Jacobi coordinates procedure :: drift => whm_drift_pl !! Loop through massive bodies and call Danby drift routine to jacobi coordinates - procedure :: fill => whm_util_copy_fill_pl !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) + procedure :: fill => whm_util_fill_pl !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) procedure :: accel => whm_kick_getacch_pl !! Compute heliocentric accelerations of massive bodies procedure :: kick => whm_kick_vh_pl !! Kick heliocentric velocities of massive bodies procedure :: accel_gr => whm_gr_kick_getacch_pl !! Acceleration term arising from the post-Newtonian correction @@ -45,7 +45,7 @@ module whm_classes 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 :: step => whm_step_pl !! Steps the body forward one stepsize - procedure :: spill => whm_util_copy_spill_pl !!"Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) + procedure :: spill => whm_util_spill_pl !!"Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) end type whm_pl !******************************************************************************************************************************** @@ -55,7 +55,7 @@ module whm_classes !! WHM test particle class type, extends(swiftest_tp) :: whm_tp !! Note to developers: If you add componenets to this class, be sure to update methods and subroutines that traverse the - !! component list, such as whm_util_copy_spill_tp + !! component list, such as whm_util_spill_tp contains procedure :: accel => whm_kick_getacch_tp !! Compute heliocentric accelerations of test particles procedure :: kick => whm_kick_vh_tp !! Kick heliocentric velocities of test particles @@ -106,13 +106,13 @@ module subroutine whm_drift_pl(self, system, param, dt) real(DP), intent(in) :: dt !! Stepsize end subroutine whm_drift_pl - module subroutine whm_util_copy_fill_pl(self, inserts, lfill_list) + module subroutine whm_util_fill_pl(self, inserts, lfill_list) use swiftest_classes, only : swiftest_body implicit none class(whm_pl), intent(inout) :: self !! WHM massive body object class(swiftest_body), intent(in) :: inserts !! inserted object logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - end subroutine whm_util_copy_fill_pl + end subroutine whm_util_fill_pl !> Get heliocentric accelration of massive bodies module subroutine whm_kick_getacch_pl(self, system, param, t, lbeg) @@ -249,13 +249,14 @@ module subroutine whm_step_tp(self, system, param, t, dt) real(DP), intent(in) :: dt !! Stepsize end subroutine whm_step_tp - module subroutine whm_util_copy_spill_pl(self, discards, lspill_list) + module subroutine whm_util_spill_pl(self, discards, lspill_list, ldestructive) use swiftest_classes, only : swiftest_body implicit none class(whm_pl), intent(inout) :: self !! WHM massive body object class(swiftest_body), intent(inout) :: discards !! Discarded object logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards - end subroutine whm_util_copy_spill_pl + logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not + end subroutine whm_util_spill_pl !> Steps the Swiftest nbody system forward in time one stepsize module subroutine whm_step_system(self, param, t, dt) diff --git a/src/rmvs/rmvs_util.f90 b/src/rmvs/rmvs_util.f90 index 90949e593..e9804bff6 100644 --- a/src/rmvs/rmvs_util.f90 +++ b/src/rmvs/rmvs_util.f90 @@ -2,7 +2,7 @@ use swiftest contains - module subroutine rmvs_util_copy_fill_pl(self, inserts, lfill_list) + module subroutine rmvs_util_fill_pl(self, inserts, lfill_list) !! author: David A. Minton !! !! Insert new RMVS massive body structure into an old one. @@ -24,17 +24,17 @@ module subroutine rmvs_util_copy_fill_pl(self, inserts, lfill_list) call util_fill(keeps%tpenc1P, inserts%tpenc1P, lfill_list) call util_fill(keeps%plind, inserts%plind, lfill_list) - call whm_util_copy_fill_pl(keeps, inserts, lfill_list) + call whm_util_fill_pl(keeps, inserts, lfill_list) class default write(*,*) 'Error! spill method called for incompatible return type on rmvs_pl' end select end associate return - end subroutine rmvs_util_copy_fill_pl + end subroutine rmvs_util_fill_pl - module subroutine rmvs_util_copy_fill_tp(self, inserts, lfill_list) + module subroutine rmvs_util_fill_tp(self, inserts, lfill_list) !! author: David A. Minton !! !! Insert new RMVS test particle structure into an old one. @@ -54,14 +54,14 @@ module subroutine rmvs_util_copy_fill_tp(self, inserts, lfill_list) call util_fill(keeps%plperP, inserts%plperP, lfill_list) call util_fill(keeps%plencP, inserts%plencP, lfill_list) - call util_copy_fill_tp(keeps, inserts, lfill_list) + call util_fill_tp(keeps, inserts, lfill_list) class default write(*,*) 'Error! fill method called for incompatible return type on rmvs_tp' end select end associate return - end subroutine rmvs_util_copy_fill_tp + end subroutine rmvs_util_fill_tp module subroutine rmvs_util_sort_pl(self, sortby, ascending) !! author: David A. Minton @@ -202,7 +202,7 @@ module subroutine rmvs_util_sort_rearrange_tp(self, ind) end subroutine rmvs_util_sort_rearrange_tp - module subroutine rmvs_util_copy_spill_pl(self, discards, lspill_list) + module subroutine rmvs_util_spill_pl(self, discards, lspill_list, ldestructive) !! author: David A. Minton !! !! Move spilled (discarded) RMVS test particle structure from active list to discard list @@ -210,30 +210,30 @@ module subroutine rmvs_util_copy_spill_pl(self, discards, lspill_list) !! Adapted from David E. Kaufmann's Swifter routine discard_discard_spill.f90 implicit none ! Arguments - class(rmvs_pl), intent(inout) :: self !! RMVS massive body body object - class(swiftest_body), intent(inout) :: discards !! Discarded object - logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards + class(rmvs_pl), intent(inout) :: self !! RMVS massive body body object + class(swiftest_body), intent(inout) :: discards !! Discarded object + 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 associate(keeps => self) select type(discards) class is (rmvs_pl) - discards%nenc(:) = pack(keeps%nenc(:), lspill_list(:)) - if (count(.not.lspill_list(:)) > 0) then - keeps%nenc(:) = pack(keeps%nenc(:), .not. lspill_list(:)) - end if - call whm_util_copy_spill_pl(keeps, discards, lspill_list) + 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 write(*,*) 'Error! spill method called for incompatible return type on rmvs_pl' end select end associate return - end subroutine rmvs_util_copy_spill_pl + end subroutine rmvs_util_spill_pl - module subroutine rmvs_util_copy_spill_tp(self, discards, lspill_list) + module subroutine rmvs_util_spill_tp(self, discards, lspill_list, ldestructive) !! author: David A. Minton !! !! Move spilled (discarded) RMVS test particle structure from active list to discard list @@ -244,28 +244,24 @@ module subroutine rmvs_util_copy_spill_tp(self, discards, lspill_list) class(rmvs_tp), intent(inout) :: self !! RMVS test particle object class(swiftest_body), intent(inout) :: discards !! Discarded object 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 associate(keeps => self) select type(discards) class is (rmvs_tp) - discards%lperi(:) = pack(keeps%lperi(:), lspill_list(:)) - discards%plperP(:) = pack(keeps%plperP(:), lspill_list(:)) - discards%plencP(:) = pack(keeps%plencP(:), lspill_list(:)) - if (count(.not.lspill_list(:)) > 0) then - keeps%lperi(:) = pack(keeps%lperi(:), .not. lspill_list(:)) - keeps%plperP(:) = pack(keeps%plperP(:), .not. lspill_list(:)) - keeps%plencP(:) = pack(keeps%plencP(:), .not. lspill_list(:)) - end if - - call util_copy_spill_tp(keeps, discards, lspill_list) + 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 util_spill_tp(keeps, discards, lspill_list, ldestructive) class default write(*,*) 'Error! spill method called for incompatible return type on rmvs_tp' end select end associate return - end subroutine rmvs_util_copy_spill_tp + end subroutine rmvs_util_spill_tp end submodule s_rmvs_util diff --git a/src/symba/symba_util.f90 b/src/symba/symba_util.f90 index 96781555c..8c9a0a1d7 100644 --- a/src/symba/symba_util.f90 +++ b/src/symba/symba_util.f90 @@ -2,7 +2,7 @@ use swiftest contains - module subroutine symba_util_copy_fill_pl(self, inserts, lfill_list) + module subroutine symba_util_fill_pl(self, inserts, lfill_list) !! author: David A. Minton !! !! Insert new SyMBA test particle structure into an old one. @@ -34,16 +34,16 @@ module subroutine symba_util_copy_fill_pl(self, inserts, lfill_list) keeps%info(:) = unpack(keeps%info(:), .not.lfill_list(:), keeps%info(:)) keeps%info(:) = unpack(inserts%info(:), lfill_list(:), keeps%info(:)) - call util_copy_fill_pl(keeps, inserts, lfill_list) + call util_fill_pl(keeps, inserts, lfill_list) class default write(*,*) 'Error! fill method called for incompatible return type on symba_pl' end select end associate return - end subroutine symba_util_copy_fill_pl + end subroutine symba_util_fill_pl - module subroutine symba_util_copy_fill_tp(self, inserts, lfill_list) + module subroutine symba_util_fill_tp(self, inserts, lfill_list) !! author: David A. Minton !! !! Insert new SyMBA test particle structure into an old one. @@ -62,14 +62,14 @@ module subroutine symba_util_copy_fill_tp(self, inserts, lfill_list) call util_fill(keeps%levelg, inserts%levelg, lfill_list) call util_fill(keeps%levelm, inserts%levelm, lfill_list) - call util_copy_fill_tp(keeps, inserts, lfill_list) + call util_fill_tp(keeps, inserts, lfill_list) class default write(*,*) 'Error! fill method called for incompatible return type on symba_tp' end select end associate return - end subroutine symba_util_copy_fill_tp + end subroutine symba_util_fill_tp module subroutine symba_util_copy_pltpenc(self, source) !! author: David A. Minton @@ -310,7 +310,7 @@ module subroutine symba_util_sort_rearrange_tp(self, ind) end subroutine symba_util_sort_rearrange_tp - module subroutine symba_util_copy_spill_pl(self, discards, lspill_list) + module subroutine symba_util_spill_pl(self, discards, lspill_list, ldestructive) !! author: David A. Minton !! !! Move spilled (discarded) SyMBA massive body particle structure from active list to discard list @@ -320,6 +320,7 @@ module subroutine symba_util_copy_spill_pl(self, discards, lspill_list) class(symba_pl), intent(inout) :: self !! SyMBA massive body object class(swiftest_body), intent(inout) :: discards !! Discarded object 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 body by removing the discard list ! Internals integer(I4B) :: i @@ -328,54 +329,48 @@ module subroutine symba_util_copy_spill_pl(self, discards, lspill_list) associate(keeps => self) select type(discards) class is (symba_pl) - discards%lcollision(:) = pack(keeps%lcollision(:), lspill_list(:)) - discards%lencounter(:) = pack(keeps%lencounter(:), lspill_list(:)) - discards%lmtiny(:) = pack(keeps%lmtiny(:), lspill_list(:)) - discards%nplenc(:) = pack(keeps%nplenc(:), lspill_list(:)) - discards%ntpenc(:) = pack(keeps%ntpenc(:), lspill_list(:)) - discards%levelg(:) = pack(keeps%levelg(:), lspill_list(:)) - discards%levelm(:) = pack(keeps%levelm(:), lspill_list(:)) - discards%isperi(:) = pack(keeps%isperi(:), lspill_list(:)) - discards%peri(:) = pack(keeps%peri(:), lspill_list(:)) - discards%atp(:) = pack(keeps%atp(:), lspill_list(:)) + + call util_spill(keeps%lcollision, discards%lcollision, lspill_list, ldestructive) + call util_spill(keeps%lencounter, discards%lencounter, 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) + call util_spill(keeps%levelg, discards%levelg, lspill_list, ldestructive) + call util_spill(keeps%levelm, discards%levelm, 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) discards%info(:) = pack(keeps%info(:), lspill_list(:)) discards%kin(:) = pack(keeps%kin(:), lspill_list(:)) - if (count(.not.lspill_list(:)) > 0) then - keeps%lcollision(:) = pack(keeps%lcollision(:), .not. lspill_list(:)) - keeps%lencounter(:) = pack(keeps%lencounter(:), .not. lspill_list(:)) - keeps%lmtiny(:) = pack(keeps%lmtiny(:), .not. lspill_list(:)) - keeps%nplenc(:) = pack(keeps%nplenc(:), .not. lspill_list(:)) - keeps%ntpenc(:) = pack(keeps%ntpenc(:), .not. lspill_list(:)) - keeps%levelg(:) = pack(keeps%levelg(:), .not. lspill_list(:)) - keeps%levelm(:) = pack(keeps%levelm(:), .not. lspill_list(:)) - keeps%isperi(:) = pack(keeps%isperi(:), .not. lspill_list(:)) - keeps%peri(:) = pack(keeps%peri(:), .not. lspill_list(:)) - keeps%atp(:) = pack(keeps%atp(:), .not. lspill_list(:)) - keeps%info(:) = pack(keeps%info(:), .not. lspill_list(:)) - keeps%kin(:) = pack(keeps%kin(:), .not. lspill_list(:)) + if (ldestructive) then + if (count(.not.lspill_list(:)) > 0) then + keeps%info(:) = pack(keeps%info(:), .not. lspill_list(:)) + keeps%kin(:) = pack(keeps%kin(:), .not. lspill_list(:)) + end if end if - call util_copy_spill_pl(keeps, discards, lspill_list) + call util_spill_pl(keeps, discards, lspill_list, ldestructive) class default write(*,*) 'Error! spill method called for incompatible return type on symba_pl' end select end associate return - end subroutine symba_util_copy_spill_pl + end subroutine symba_util_spill_pl - module subroutine symba_util_copy_spill_tp(self, discards, lspill_list) + module subroutine symba_util_spill_tp(self, discards, lspill_list, ldestructive) !! author: David A. Minton !! !! Move spilled (discarded) SyMBA test particle structure from active list to discard list !! Adapted from David E. Kaufmann's Swifter routine whm_discard_spill.f90 implicit none ! Arguments - class(symba_tp), intent(inout) :: self !! SyMBA test particle object - class(swiftest_body), intent(inout) :: discards !! Discarded object - logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards + class(symba_tp), intent(inout) :: self !! SyMBA test particle object + class(swiftest_body), intent(inout) :: discards !! Discarded object + 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 body by removing the discard list ! Internals integer(I4B) :: i @@ -384,23 +379,17 @@ module subroutine symba_util_copy_spill_tp(self, discards, lspill_list) associate(keeps => self) select type(discards) class is (symba_pl) - discards%nplenc(:) = pack(keeps%nplenc(:), lspill_list(:)) - discards%levelg(:) = pack(keeps%levelg(:), lspill_list(:)) - discards%levelm(:) = pack(keeps%levelm(:), lspill_list(:)) - - if (count(.not.lspill_list(:)) > 0) then - keeps%nplenc(:) = pack(keeps%nplenc(:), .not. lspill_list(:)) - keeps%levelg(:) = pack(keeps%levelg(:), .not. lspill_list(:)) - keeps%levelm(:) = pack(keeps%levelm(:), .not. lspill_list(:)) - end if + 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 util_copy_spill_tp(keeps, discards, lspill_list) + call util_spill_tp(keeps, discards, lspill_list, ldestructive) class default write(*,*) 'Error! spill method called for incompatible return type on symba_pl' end select end associate return - end subroutine symba_util_copy_spill_tp + end subroutine symba_util_spill_tp end submodule s_symba_util \ No newline at end of file diff --git a/src/util/util_copy.f90 b/src/util/util_copy.f90 index 60cf568b4..bc8cdcf43 100644 --- a/src/util/util_copy.f90 +++ b/src/util/util_copy.f90 @@ -32,255 +32,4 @@ module subroutine util_copy_into_body(self, source, param, lsource_mask) return end subroutine util_copy_into_body - - module subroutine util_copy_spill_body(self, discards, lspill_list) - !! author: David A. Minton - !! - !! Move spilled (discarded) Swiftest generic particle structure from active list to discard list - !! Adapted from David E. Kaufmann's Swifter routine whm_discard_spill.f90 - implicit none - ! Arguments - class(swiftest_body), intent(inout) :: self !! Swiftest generic body object - class(swiftest_body), intent(inout) :: discards !! Discarded object - logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards - ! Internals - integer(I4B) :: i - - ! For each component, pack the discarded bodies into the discard object and do the inverse with the keeps - !> Spill all the common components - associate(keeps => self) - discards%id(:) = pack(keeps%id(:), lspill_list(:)) - discards%name(:) = pack(keeps%name(:), lspill_list(:)) - discards%status(:) = pack(keeps%status(:), lspill_list(:)) - discards%mu(:) = pack(keeps%mu(:), lspill_list(:)) - discards%lmask(:) = pack(keeps%lmask(:), lspill_list(:)) - do i = 1, NDIM - discards%xh(i, :) = pack(keeps%xh(i, :), lspill_list(:)) - discards%vh(i, :) = pack(keeps%vh(i, :), lspill_list(:)) - discards%xb(i, :) = pack(keeps%xb(i, :), lspill_list(:)) - discards%vb(i, :) = pack(keeps%vb(i, :), lspill_list(:)) - discards%ah(i, :) = pack(keeps%ah(i, :), lspill_list(:)) - end do - - if (allocated(keeps%a)) discards%a(:) = pack(keeps%a(:), lspill_list(:)) - if (allocated(keeps%e)) discards%e(:) = pack(keeps%e(:), lspill_list(:)) - if (allocated(keeps%capom)) discards%capom(:) = pack(keeps%capom(:), lspill_list(:)) - if (allocated(keeps%omega)) discards%omega(:) = pack(keeps%omega(:), lspill_list(:)) - if (allocated(keeps%capm)) discards%capm(:) = pack(keeps%capm(:), lspill_list(:)) - - if (allocated(keeps%aobl)) then - do i = 1, NDIM - discards%aobl(i, :) = pack(keeps%aobl(i, :), lspill_list(:)) - end do - end if - if (allocated(keeps%agr)) then - do i = 1, NDIM - discards%agr(i, :) = pack(keeps%agr(i, :), lspill_list(:)) - end do - end if - if (allocated(keeps%atide)) then - do i = 1, NDIM - discards%atide(i, :) = pack(keeps%atide(i, :), lspill_list(:)) - end do - end if - - if (count(.not.lspill_list(:)) > 0) then - keeps%id(:) = pack(keeps%id(:), .not. lspill_list(:)) - keeps%name(:) = pack(keeps%name(:), .not. lspill_list(:)) - keeps%status(:) = pack(keeps%status(:), .not. lspill_list(:)) - keeps%mu(:) = pack(keeps%mu(:), .not. lspill_list(:)) - keeps%lmask(:) = pack(keeps%lmask(:), .not. lspill_list(:)) - - do i = 1, NDIM - keeps%xh(i, :) = pack(keeps%xh(i, :), .not. lspill_list(:)) - keeps%vh(i, :) = pack(keeps%vh(i, :), .not. lspill_list(:)) - keeps%xb(i, :) = pack(keeps%xb(i, :), .not. lspill_list(:)) - keeps%vb(i, :) = pack(keeps%vb(i, :), .not. lspill_list(:)) - keeps%ah(i, :) = pack(keeps%ah(i, :), .not. lspill_list(:)) - end do - - if (allocated(keeps%a)) keeps%a(:) = pack(keeps%a(:), .not. lspill_list(:)) - if (allocated(keeps%e)) keeps%e(:) = pack(keeps%e(:), .not. lspill_list(:)) - if (allocated(keeps%inc)) keeps%inc(:) = pack(keeps%inc(:), .not. lspill_list(:)) - if (allocated(keeps%capom)) keeps%capom(:) = pack(keeps%capom(:), .not. lspill_list(:)) - if (allocated(keeps%omega)) keeps%omega(:) = pack(keeps%omega(:), .not. lspill_list(:)) - if (allocated(keeps%capm)) keeps%capm(:) = pack(keeps%capm(:), .not. lspill_list(:)) - - if (allocated(keeps%aobl)) then - do i = 1, NDIM - keeps%aobl(i, :) = pack(keeps%aobl(i, :), .not. lspill_list(:)) - end do - end if - - if (allocated(keeps%agr)) then - do i = 1, NDIM - keeps%agr(i, :) = pack(keeps%agr(i, :), .not. lspill_list(:)) - end do - end if - - if (allocated(keeps%atide)) then - do i = 1, NDIM - keeps%atide(i, :) = pack(keeps%atide(i, :), .not. lspill_list(:)) - end do - end if - - end if - ! This is the base class, so will be the last to be called in the cascade. - ! Therefore we need to set the nbody values for both the keeps and discareds - discards%nbody = count(lspill_list(:)) - keeps%nbody = count(.not.lspill_list(:)) - if (allocated(keeps%ldiscard)) deallocate(keeps%ldiscard) - if (allocated(discards%ldiscard)) deallocate(discards%ldiscard) - allocate(keeps%ldiscard(keeps%nbody)) - allocate(discards%ldiscard(discards%nbody)) - keeps%ldiscard = .false. - discards%ldiscard = .true. - end associate - - return - end subroutine util_copy_spill_body - - - module subroutine util_copy_spill_pl(self, discards, lspill_list) - !! author: David A. Minton - !! - !! Move spilled (discarded) Swiftest massive body structure from active list to discard list - !! Adapted from David E. Kaufmann's Swifter routine whm_discard_spill.f90 - implicit none - ! Arguments - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_body), intent(inout) :: discards !! Discarded object - logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards - ! Internals - integer(I4B) :: i - - associate(keeps => self) - - 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 - discards%mass(:) = pack(keeps%mass(:), lspill_list(:)) - discards%Gmass(:) = pack(keeps%Gmass(:), lspill_list(:)) - discards%rhill(:) = pack(keeps%rhill(:), lspill_list(:)) - - if (allocated(keeps%radius)) discards%radius(:) = pack(keeps%radius(:), lspill_list(:)) - if (allocated(keeps%density)) discards%density(:) = pack(keeps%density(:), lspill_list(:)) - if (allocated(keeps%k2)) discards%k2(:) = pack(keeps%k2(:), lspill_list(:)) - if (allocated(keeps%Q)) discards%Q(:) = pack(keeps%Q(:), lspill_list(:)) - if (allocated(keeps%tlag)) discards%tlag(:) = pack(keeps%tlag(:), lspill_list(:)) - - if (allocated(keeps%xbeg)) then - do i = 1, NDIM - discards%xbeg(i, :) = pack(keeps%xbeg(i, :), lspill_list(:)) - end do - end if - - if (allocated(keeps%xend)) then - do i = 1, NDIM - discards%xend(i, :) = pack(keeps%xend(i, :), lspill_list(:)) - end do - end if - - if (allocated(keeps%vbeg)) then - do i = 1, NDIM - discards%vbeg(i, :) = pack(keeps%vbeg(i, :), lspill_list(:)) - end do - end if - - if (allocated(keeps%Ip)) then - do i = 1, NDIM - discards%Ip(i, :) = pack(keeps%Ip(i, :), lspill_list(:)) - end do - end if - - if (allocated(keeps%rot)) then - do i = 1, NDIM - discards%rot(i, :) = pack(keeps%rot(i, :), lspill_list(:)) - end do - end if - - if (count(.not.lspill_list(:)) > 0) then - keeps%mass(:) = pack(keeps%mass(:), .not. lspill_list(:)) - keeps%Gmass(:) = pack(keeps%Gmass(:), .not. lspill_list(:)) - keeps%rhill(:) = pack(keeps%rhill(:), .not. lspill_list(:)) - if (allocated(keeps%radius)) keeps%radius(:) = pack(keeps%radius(:), .not. lspill_list(:)) - if (allocated(keeps%density)) keeps%density(:) = pack(keeps%density(:), .not. lspill_list(:)) - if (allocated(keeps%k2)) keeps%k2(:) = pack(keeps%k2(:), .not. lspill_list(:)) - if (allocated(keeps%Q)) keeps%Q(:) = pack(keeps%Q(:), .not. lspill_list(:)) - if (allocated(keeps%tlag)) keeps%tlag(:) = pack(keeps%tlag(:), .not. lspill_list(:)) - - if (allocated(keeps%xbeg)) then - do i = 1, NDIM - keeps%xbeg(i,:) = pack(keeps%xbeg(i,:), .not. lspill_list(:)) - end do - end if - - if (allocated(keeps%xend)) then - do i = 1, NDIM - keeps%xend(i,:) = pack(keeps%xend(i,:), .not. lspill_list(:)) - end do - end if - - if (allocated(keeps%vbeg)) then - do i = 1, NDIM - keeps%vbeg(i,:) = pack(keeps%vbeg(i,:), .not. lspill_list(:)) - end do - end if - - if (allocated(keeps%Ip)) then - do i = 1, NDIM - keeps%Ip(i,:) = pack(keeps%Ip(i,:), .not. lspill_list(:)) - end do - end if - - if (allocated(keeps%rot)) then - do i = 1, NDIM - keeps%rot(i,:) = pack(keeps%rot(i,:), .not. lspill_list(:)) - end do - end if - - end if - - call util_copy_spill_body(keeps, discards, lspill_list) - class default - write(*,*) 'Error! spill method called for incompatible return type on swiftest_pl' - end select - end associate - - return - end subroutine util_copy_spill_pl - - - module subroutine util_copy_spill_tp(self, discards, lspill_list) - !! author: David A. Minton - !! - !! Move spilled (discarded) Swiftest test particle structure from active list to discard list - !! Adapted from David E. Kaufmann's Swifter routine whm_discard_spill.f90 - implicit none - ! Arguments - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - class(swiftest_body), intent(inout) :: discards !! Discarded object - logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discardse - - associate(keeps => self, ntp => self%nbody) - select type(discards) - class is (swiftest_tp) - !> Spill components specific to the test particle class - discards%isperi(:) = pack(keeps%isperi(:), lspill_list(:)) - discards%peri(:) = pack(keeps%peri(:), lspill_list(:)) - discards%atp(:) = pack(keeps%atp(:), lspill_list(:)) - if (count(.not.lspill_list(:)) > 0) then - keeps%atp(:) = pack(keeps%atp(:), .not. lspill_list(:)) - keeps%peri(:) = pack(keeps%peri(:), .not. lspill_list(:)) - keeps%isperi(:) = pack(keeps%isperi(:), .not. lspill_list(:)) - end if - call util_copy_spill_body(keeps, discards, lspill_list) - class default - write(*,*) 'Error! spill method called for incompatible return type on swiftest_tp' - end select - end associate - - return - end subroutine util_copy_spill_tp - end submodule s_util_copy \ No newline at end of file diff --git a/src/util/util_fill.f90 b/src/util/util_fill.f90 index 47981c038..4a5a70311 100644 --- a/src/util/util_fill.f90 +++ b/src/util/util_fill.f90 @@ -10,7 +10,7 @@ module subroutine util_fill_arr_char_string(keeps, inserts, lfill_list) 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 arrays to insert into 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 @@ -29,7 +29,7 @@ module subroutine util_fill_arr_DP(keeps, inserts, lfill_list) implicit none ! Arguments real(DP), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - real(DP), dimension(:), allocatable, intent(in) :: inserts !! Array of arrays to insert into 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 @@ -48,7 +48,7 @@ module subroutine util_fill_arr_DPvec(keeps, inserts, lfill_list) implicit none ! Arguments real(DP), dimension(:,:), allocatable, intent(inout) :: keeps !! Array of values to keep - real(DP), dimension(:,:), allocatable, intent(in) :: inserts !! Array of arrays to insert into 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 @@ -71,7 +71,7 @@ module subroutine util_fill_arr_I4B(keeps, inserts, lfill_list) implicit none ! Arguments integer(I4B), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - integer(I4B), dimension(:), allocatable, intent(in) :: inserts !! Array of arrays to insert into 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 @@ -90,7 +90,7 @@ module subroutine util_fill_arr_logical(keeps, inserts, lfill_list) implicit none ! Arguments logical, dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - logical, dimension(:), allocatable, intent(in) :: inserts !! Array of arrays to insert into 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 @@ -102,7 +102,7 @@ module subroutine util_fill_arr_logical(keeps, inserts, lfill_list) end subroutine util_fill_arr_logical - module subroutine util_copy_fill_body(self, inserts, lfill_list) + module subroutine util_fill_body(self, inserts, lfill_list) !! author: David A. Minton !! !! Insert new Swiftest generic particle structure into an old one. @@ -122,6 +122,7 @@ module subroutine util_copy_fill_body(self, inserts, lfill_list) call util_fill(keeps%name, inserts%name, lfill_list) call util_fill(keeps%status, inserts%status, lfill_list) call util_fill(keeps%ldiscard, inserts%ldiscard, lfill_list) + call util_fill(keeps%lmask, inserts%lmask, lfill_list) call util_fill(keeps%mu, inserts%mu, lfill_list) call util_fill(keeps%xh, inserts%xh, lfill_list) call util_fill(keeps%vh, inserts%vh, lfill_list) @@ -143,10 +144,10 @@ module subroutine util_copy_fill_body(self, inserts, lfill_list) end associate return - end subroutine util_copy_fill_body + end subroutine util_fill_body - module subroutine util_copy_fill_pl(self, inserts, lfill_list) + module subroutine util_fill_pl(self, inserts, lfill_list) !! author: David A. Minton !! !! Insert new Swiftest massive body structure into an old one. @@ -177,17 +178,17 @@ module subroutine util_copy_fill_pl(self, inserts, lfill_list) call util_fill(keeps%Ip, inserts%Ip, lfill_list) call util_fill(keeps%rot, inserts%rot, lfill_list) - call util_copy_fill_body(keeps, inserts, lfill_list) + call util_fill_body(keeps, inserts, lfill_list) class default write(*,*) 'Error! fill method called for incompatible return type on swiftest_pl' end select end associate return - end subroutine util_copy_fill_pl + end subroutine util_fill_pl - module subroutine util_copy_fill_tp(self, inserts, lfill_list) + module subroutine util_fill_tp(self, inserts, lfill_list) !! author: David A. Minton !! !! Insert new Swiftest test particle structure into an old one. @@ -206,13 +207,13 @@ module subroutine util_copy_fill_tp(self, inserts, lfill_list) call util_fill(keeps%peri, inserts%peri, lfill_list) call util_fill(keeps%atp, inserts%atp, lfill_list) - call util_copy_fill_body(keeps, inserts, lfill_list) + call util_fill_body(keeps, inserts, lfill_list) class default write(*,*) 'Error! fill method called for incompatible return type on swiftest_tp' end select end associate return - end subroutine util_copy_fill_tp + end subroutine util_fill_tp end submodule s_util_fill \ No newline at end of file diff --git a/src/util/util_spill.f90 b/src/util/util_spill.f90 new file mode 100644 index 000000000..5f942854a --- /dev/null +++ b/src/util/util_spill.f90 @@ -0,0 +1,269 @@ +submodule (swiftest_classes) s_util_spill + use swiftest +contains + + module subroutine 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 + + if (.not.allocated(keeps) .or. count(lspill_list(:)) == 0) return + if (.not.allocated(discards)) allocate(discards(count(lspill_list(:)))) + + discards(:) = pack(keeps(:), lspill_list(:)) + if (ldestructive) then + if (count(.not.lspill_list(:)) > 0) then + keeps(:) = pack(keeps(:), .not. lspill_list(:)) + else + deallocate(keeps) + end if + end if + + return + end subroutine util_spill_arr_char_string + + module subroutine 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 + + if (.not.allocated(keeps) .or. count(lspill_list(:)) == 0) return + if (.not.allocated(discards)) allocate(discards(count(lspill_list(:)))) + + discards(:) = pack(keeps(:), lspill_list(:)) + if (ldestructive) then + if (count(.not.lspill_list(:)) > 0) then + keeps(:) = pack(keeps(:), .not. lspill_list(:)) + else + deallocate(keeps) + end if + end if + + return + end subroutine util_spill_arr_DP + + module subroutine 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 + + if (.not.allocated(keeps) .or. count(lspill_list(:)) == 0) return + if (.not.allocated(discards)) allocate(discards(NDIM, count(lspill_list(:)))) + + do i = 1, NDIM + discards(i,:) = pack(keeps(i,:), lspill_list(:)) + end do + if (ldestructive) then + if (count(.not.lspill_list(:)) > 0) then + do i = 1, NDIM + keeps(i,:) = pack(keeps(i,:), .not. lspill_list(:)) + end do + end if + end if + + return + end subroutine util_spill_arr_DPvec + + module subroutine 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 + + if (.not.allocated(keeps) .or. count(lspill_list(:)) == 0) return + if (.not.allocated(discards)) allocate(discards(count(lspill_list(:)))) + + discards(:) = pack(keeps(:), lspill_list(:)) + if (ldestructive) then + if (count(.not.lspill_list(:)) > 0) then + keeps(:) = pack(keeps(:), .not. lspill_list(:)) + else + deallocate(keeps) + end if + end if + + return + end subroutine util_spill_arr_I4B + + module subroutine 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 + + if (.not.allocated(keeps) .or. count(lspill_list(:)) == 0) return + if (.not.allocated(discards)) allocate(discards(count(lspill_list(:)))) + + discards(:) = pack(keeps(:), lspill_list(:)) + if (ldestructive) then + if (count(.not.lspill_list(:)) > 0) then + keeps(:) = pack(keeps(:), .not. lspill_list(:)) + else + deallocate(keeps) + end if + end if + + return + end subroutine util_spill_arr_logical + + + module subroutine util_spill_body(self, discards, lspill_list, ldestructive) + !! author: David A. Minton + !! + !! Move spilled (discarded) Swiftest generic particle structure from active list to discard list + !! Adapted from David E. Kaufmann's Swifter routine whm_discard_spill.f90 + implicit none + ! Arguments + class(swiftest_body), intent(inout) :: self !! Swiftest generic body object + class(swiftest_body), intent(inout) :: discards !! Discarded object + 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 body by removing the discard list + ! Internals + integer(I4B) :: i + + ! For each component, pack the discarded bodies into the discard object and do the inverse with the keeps + !> Spill all the common components + associate(keeps => self) + call util_spill(keeps%id, discards%id, lspill_list, ldestructive) + call util_spill(keeps%name, discards%name, lspill_list, ldestructive) + call util_spill(keeps%status, discards%status, lspill_list, ldestructive) + call util_spill(keeps%lmask, discards%lmask, lspill_list, ldestructive) + call util_spill(keeps%mu, discards%mu, lspill_list, ldestructive) + call util_spill(keeps%xh, discards%xh, lspill_list, ldestructive) + call util_spill(keeps%vh, discards%vh, lspill_list, ldestructive) + call util_spill(keeps%xb, discards%xb, 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%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) + + ! This is the base class, so will be the last to be called in the cascade. + ! Therefore we need to set the nbody values for both the keeps and discareds + discards%nbody = count(lspill_list(:)) + keeps%nbody = count(.not.lspill_list(:)) + if (allocated(keeps%ldiscard)) deallocate(keeps%ldiscard) + if (allocated(discards%ldiscard)) deallocate(discards%ldiscard) + allocate(keeps%ldiscard(keeps%nbody)) + allocate(discards%ldiscard(discards%nbody)) + keeps%ldiscard = .false. + discards%ldiscard = .true. + end associate + + return + end subroutine util_spill_body + + + module subroutine util_spill_pl(self, discards, lspill_list, ldestructive) + !! author: David A. Minton + !! + !! Move spilled (discarded) Swiftest massive body structure from active list to discard list + !! Adapted from David E. Kaufmann's Swifter routine whm_discard_spill.f90 + implicit none + ! Arguments + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_body), intent(inout) :: discards !! Discarded object + 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 body by removing the discard list + ! Internals + integer(I4B) :: i + + associate(keeps => self) + + 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 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%radius, discards%radius, lspill_list, ldestructive) + call util_spill(keeps%density, discards%density, 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%xbeg, discards%xbeg, 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_body(keeps, discards, lspill_list, ldestructive) + class default + write(*,*) 'Error! spill method called for incompatible return type on swiftest_pl' + end select + end associate + + return + end subroutine util_spill_pl + + + module subroutine util_spill_tp(self, discards, lspill_list, ldestructive) + !! author: David A. Minton + !! + !! Move spilled (discarded) Swiftest test particle structure from active list to discard list + !! Adapted from David E. Kaufmann's Swifter routine whm_discard_spill.f90 + implicit none + ! Arguments + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + class(swiftest_body), intent(inout) :: discards !! Discarded object + logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discardse + logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter body by removing the discard list + + associate(keeps => self, ntp => self%nbody) + select type(discards) + class is (swiftest_tp) + !> Spill components specific to the test particle class + 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_body(keeps, discards, lspill_list, ldestructive) + class default + write(*,*) 'Error! spill method called for incompatible return type on swiftest_tp' + end select + end associate + + return + end subroutine util_spill_tp + +end submodule s_util_spill \ No newline at end of file diff --git a/src/whm/whm_util.f90 b/src/whm/whm_util.f90 index ab5461f2d..dbcd9c916 100644 --- a/src/whm/whm_util.f90 +++ b/src/whm/whm_util.f90 @@ -2,7 +2,7 @@ use swiftest contains - module subroutine whm_util_copy_spill_pl(self, discards, lspill_list) + module subroutine whm_util_spill_pl(self, discards, lspill_list, ldestructive) !! author: David A. Minton !! !! Move spilled (discarded) WHM test particle structure from active list to discard list @@ -13,39 +13,29 @@ module subroutine whm_util_copy_spill_pl(self, discards, lspill_list) class(whm_pl), intent(inout) :: self !! WHM massive body object class(swiftest_body), intent(inout) :: discards !! Discarded object 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 associate(keeps => self) select type(discards) class is (whm_pl) - discards%eta(:) = pack(keeps%eta(:), lspill_list(:)) - discards%muj(:) = pack(keeps%muj(:), lspill_list(:)) - discards%ir3j(:) = pack(keeps%ir3j(:), lspill_list(:)) - do i = 1, NDIM - discards%xj(i, :) = pack(keeps%xj(i, :), lspill_list(:)) - discards%vj(i, :) = pack(keeps%vj(i, :), lspill_list(:)) - end do - - if (count(.not.lspill_list(:)) > 0) then - keeps%eta(:) = pack(keeps%eta(:), .not. lspill_list(:)) - keeps%muj(:) = pack(keeps%muj(:), .not. lspill_list(:)) - keeps%ir3j(:) = pack(keeps%ir3j(:), .not. lspill_list(:)) - do i = 1, NDIM - keeps%xj(i, :) = pack(keeps%xj(i, :), .not. lspill_list(:)) - keeps%vj(i, :) = pack(keeps%vj(i, :), .not. lspill_list(:)) - end do - end if - call util_copy_spill_pl(keeps, discards, lspill_list) + 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 util_spill_pl(keeps, discards, lspill_list, ldestructive) class default write(*,*) 'Error! spill method called for incompatible return type on whm_pl' end select end associate return - end subroutine whm_util_copy_spill_pl + end subroutine whm_util_spill_pl - module subroutine whm_util_copy_fill_pl(self, inserts, lfill_list) + module subroutine whm_util_fill_pl(self, inserts, lfill_list) !! author: David A. Minton !! !! Insert new WHM test particle structure into an old one. @@ -69,14 +59,14 @@ module subroutine whm_util_copy_fill_pl(self, inserts, lfill_list) call util_fill(keeps%xj, inserts%xj, lfill_list) call util_fill(keeps%vj, inserts%vj, lfill_list) - call util_copy_fill_pl(keeps, inserts, lfill_list) + call util_fill_pl(keeps, inserts, lfill_list) class default write(*,*) 'Error! fill method called for incompatible return type on whm_pl' end select end associate return - end subroutine whm_util_copy_fill_pl + end subroutine whm_util_fill_pl module subroutine whm_util_set_ir3j(self)