From 8cd8464eb9ca20104b66062938d2a41902571185 Mon Sep 17 00:00:00 2001 From: David Minton Date: Sat, 31 Jul 2021 10:28:35 -0400 Subject: [PATCH] Refactored fill and spill routines into copy submodule and added a specialized copy method that uses a fill operation --- src/modules/rmvs_classes.f90 | 30 +- src/modules/swiftest_classes.f90 | 56 ++-- src/modules/whm_classes.f90 | 18 +- src/rmvs/rmvs_util.f90 | 28 +- src/util/util_append.f90 | 4 +- src/util/util_copy.f90 | 512 ++++++++++++++++++++++++++++++- src/util/util_spill_and_fill.f90 | 506 ------------------------------ src/whm/whm_util.f90 | 14 +- 8 files changed, 581 insertions(+), 587 deletions(-) delete mode 100644 src/util/util_spill_and_fill.f90 diff --git a/src/modules/rmvs_classes.f90 b/src/modules/rmvs_classes.f90 index 88e3ee217..945b96ce2 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_spill_tp + !! component list, such as rmvs_setup_tp and rmvs_util_copy_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_fill_tp !! "Fills" bodies from one object into another depending on the results of a mask (uses the MERGE intrinsic) + procedure :: fill => rmvs_util_copy_fill_tp !! "Fills" bodies from one object into another depending on the results of a mask (uses the MERGE 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_spill_tp !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) + 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) 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_fill_pl !! "Fills" bodies from one object into another depending on the results of a mask (uses the MERGE 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) + procedure :: fill => rmvs_util_copy_fill_pl !! "Fills" bodies from one object into another depending on the results of a mask (uses the MERGE 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) 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_fill_pl(self, inserts, lfill_list) + module subroutine rmvs_util_copy_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(inout) :: inserts !! Inserted 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_fill_pl + end subroutine rmvs_util_copy_fill_pl - module subroutine rmvs_util_fill_tp(self, inserts, lfill_list) + module subroutine rmvs_util_copy_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(inout) :: inserts !! Inserted 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_fill_tp + end subroutine rmvs_util_copy_fill_tp module subroutine rmvs_util_sort_pl(self, sortby, ascending) implicit none @@ -196,21 +196,21 @@ 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_spill_pl(self, discards, lspill_list) + module subroutine rmvs_util_copy_spill_pl(self, discards, lspill_list) 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_spill_pl + end subroutine rmvs_util_copy_spill_pl - module subroutine rmvs_util_spill_tp(self, discards, lspill_list) + module subroutine rmvs_util_copy_spill_tp(self, discards, lspill_list) 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_spill_tp + end subroutine rmvs_util_copy_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 ac7639bc4..5ec4fc7dc 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_spill + !! component list, such as setup_body and util_copy_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_fill_body !! "Fills" bodies from one object into another depending on the results of a mask (uses the MERGE intrinsic) + procedure :: fill => util_copy_fill_body !! "Fills" bodies from one object into another depending on the results of a mask (uses the MERGE 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_spill_body !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) + procedure :: spill => util_copy_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_spill_pl + !! component list, such as setup_pl and util_copy_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_fill_pl !! "Fills" bodies from one object into another depending on the results of a mask (uses the MERGE intrinsic) + procedure :: fill => util_copy_fill_pl !! "Fills" bodies from one object into another depending on the results of a mask (uses the MERGE 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_spill_pl !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) + procedure :: spill => util_copy_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_spill_tp + !! component list, such as setup_tp and util_copy_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_fill_tp !! "Fills" bodies from one object into another depending on the results of a mask (uses the MERGE intrinsic) + procedure :: fill => util_copy_fill_tp !! "Fills" bodies from one object into another depending on the results of a mask (uses the MERGE 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_spill_tp !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) + procedure :: spill => util_copy_spill_tp !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) end type swiftest_tp !******************************************************************************************************************************** @@ -736,12 +736,12 @@ module subroutine user_kick_getacch_body(self, system, param, t, lbeg) logical, intent(in) :: lbeg !! Optional argument that determines whether or not this is the beginning or end of the step end subroutine user_kick_getacch_body - module subroutine util_append_body(self, source, param, lmask) + module subroutine util_append_body(self, source, param, lsource_mask) implicit none class(swiftest_body), intent(inout) :: self !! Swiftest body object class(swiftest_body), intent(in) :: source !! Source object to append class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - logical, dimension(:), optional, intent(in) :: lmask !! Logical mask indicating which elements to append to + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to end subroutine util_append_body module subroutine util_coord_b2h_pl(self, cb) @@ -768,12 +768,12 @@ module subroutine util_coord_h2b_tp(self, cb) class(swiftest_cb), intent(in) :: cb !! Swiftest central body object end subroutine util_coord_h2b_tp - module subroutine util_copy_into_body(self, source, param, lmask) + module subroutine util_copy_into_body(self, source, param, lsource_mask) implicit none class(swiftest_body), intent(inout) :: self !! Swiftest body object class(swiftest_body), intent(in) :: source !! Source object to append class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - logical, dimension(:), optional, intent(in) :: lmask !! Logical mask indicating which elements to append to + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to end subroutine util_copy_into_body module subroutine util_exit(code) @@ -781,26 +781,26 @@ module subroutine util_exit(code) integer(I4B), intent(in) :: code !! Failure exit code end subroutine util_exit - module subroutine util_fill_body(self, inserts, lfill_list) + module subroutine util_copy_fill_body(self, inserts, lfill_list) implicit none class(swiftest_body), intent(inout) :: self !! Swiftest body object - class(swiftest_body), intent(inout) :: inserts !! Swiftest body object to be inserted + 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_fill_body + end subroutine util_copy_fill_body - module subroutine util_fill_pl(self, inserts, lfill_list) + module subroutine util_copy_fill_pl(self, inserts, lfill_list) implicit none class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_body), intent(inout) :: inserts !! Swiftest body object to be inserted + 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_fill_pl + end subroutine util_copy_fill_pl - module subroutine util_fill_tp(self, inserts, lfill_list) + module subroutine util_copy_fill_tp(self, inserts, lfill_list) implicit none class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - class(swiftest_body), intent(inout) :: inserts !! Swiftest body object to be inserted + 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_fill_tp + end subroutine util_copy_fill_tp module subroutine util_peri_tp(self, system, param) implicit none @@ -934,26 +934,26 @@ module subroutine util_sort_tp(self, sortby, ascending) 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_spill_body(self, discards, lspill_list) + module subroutine util_copy_spill_body(self, discards, lspill_list) 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_spill_body + end subroutine util_copy_spill_body - module subroutine util_spill_pl(self, discards, lspill_list) + module subroutine util_copy_spill_pl(self, discards, lspill_list) 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_spill_pl + end subroutine util_copy_spill_pl - module subroutine util_spill_tp(self, discards, lspill_list) + module subroutine util_copy_spill_tp(self, discards, lspill_list) 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_spill_tp + end subroutine util_copy_spill_tp module subroutine util_valid(pl, tp) implicit none diff --git a/src/modules/whm_classes.f90 b/src/modules/whm_classes.f90 index 5509a3afe..d64354c08 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_spill_pl + !! component list, such as whm_setup_pl and whm_util_copy_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_fill_pl !! "Fills" bodies from one object into another depending on the results of a mask (uses the MERGE intrinsic) + procedure :: fill => whm_util_copy_fill_pl !! "Fills" bodies from one object into another depending on the results of a mask (uses the MERGE 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_spill_pl !!"Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) + 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) 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_spill_tp + !! component list, such as whm_util_copy_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_fill_pl(self, inserts, lfill_list) + module subroutine whm_util_copy_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(inout) :: inserts !! inserted 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_fill_pl + end subroutine whm_util_copy_fill_pl !> Get heliocentric accelration of massive bodies module subroutine whm_kick_getacch_pl(self, system, param, t, lbeg) @@ -249,13 +249,13 @@ 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_spill_pl(self, discards, lspill_list) + module subroutine whm_util_copy_spill_pl(self, discards, lspill_list) 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_spill_pl + end subroutine whm_util_copy_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 27b6bd4b3..863033c17 100644 --- a/src/rmvs/rmvs_util.f90 +++ b/src/rmvs/rmvs_util.f90 @@ -2,7 +2,7 @@ use swiftest contains - module subroutine rmvs_util_fill_pl(self, inserts, lfill_list) + module subroutine rmvs_util_copy_fill_pl(self, inserts, lfill_list) !! author: David A. Minton !! !! Insert new RMVS massive body structure into an old one. @@ -11,7 +11,7 @@ module subroutine rmvs_util_fill_pl(self, inserts, lfill_list) implicit none ! Arguments class(rmvs_pl), intent(inout) :: self !! RMVS massive body object - class(swiftest_body), intent(inout) :: inserts !! Inserted object + class(swiftest_body), intent(in) :: inserts !! Inserted object logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps ! Internals integer(I4B) :: i @@ -23,17 +23,17 @@ module subroutine rmvs_util_fill_pl(self, inserts, lfill_list) keeps%nenc(:) = unpack(keeps%nenc(:), .not.lfill_list(:), keeps%nenc(:)) keeps%nenc(:) = unpack(inserts%nenc(:), lfill_list(:), keeps%nenc(:)) - call whm_util_fill_pl(keeps, inserts, lfill_list) + call whm_util_copy_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_fill_pl + end subroutine rmvs_util_copy_fill_pl - module subroutine rmvs_util_fill_tp(self, inserts, lfill_list) + module subroutine rmvs_util_copy_fill_tp(self, inserts, lfill_list) !! author: David A. Minton !! !! Insert new RMVS test particle structure into an old one. @@ -42,7 +42,7 @@ module subroutine rmvs_util_fill_tp(self, inserts, lfill_list) implicit none ! Arguments class(rmvs_tp), intent(inout) :: self !! RMVS test particle object - class(swiftest_body), intent(inout) :: inserts !! Inserted object + class(swiftest_body), intent(in) :: inserts !! Inserted object logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps associate(keeps => self) @@ -58,14 +58,14 @@ module subroutine rmvs_util_fill_tp(self, inserts, lfill_list) keeps%plencP(:) = unpack(keeps%plencP(:), .not.lfill_list(:), keeps%plencP(:)) keeps%plencP(:) = unpack(inserts%plencP(:), lfill_list(:), keeps%plencP(:)) - call util_fill_tp(keeps, inserts, lfill_list) + call util_copy_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_fill_tp + end subroutine rmvs_util_copy_fill_tp module subroutine rmvs_util_sort_pl(self, sortby, ascending) !! author: David A. Minton @@ -206,7 +206,7 @@ module subroutine rmvs_util_sort_rearrange_tp(self, ind) end subroutine rmvs_util_sort_rearrange_tp - module subroutine rmvs_util_spill_pl(self, discards, lspill_list) + module subroutine rmvs_util_copy_spill_pl(self, discards, lspill_list) !! author: David A. Minton !! !! Move spilled (discarded) RMVS test particle structure from active list to discard list @@ -227,17 +227,17 @@ module subroutine rmvs_util_spill_pl(self, discards, lspill_list) if (count(.not.lspill_list(:)) > 0) then keeps%nenc(:) = pack(keeps%nenc(:), .not. lspill_list(:)) end if - call whm_util_spill_pl(keeps, discards, lspill_list) + call whm_util_copy_spill_pl(keeps, discards, lspill_list) class default write(*,*) 'Error! spill method called for incompatible return type on rmvs_pl' end select end associate return - end subroutine rmvs_util_spill_pl + end subroutine rmvs_util_copy_spill_pl - module subroutine rmvs_util_spill_tp(self, discards, lspill_list) + module subroutine rmvs_util_copy_spill_tp(self, discards, lspill_list) !! author: David A. Minton !! !! Move spilled (discarded) RMVS test particle structure from active list to discard list @@ -263,13 +263,13 @@ module subroutine rmvs_util_spill_tp(self, discards, lspill_list) keeps%plencP(:) = pack(keeps%plencP(:), .not. lspill_list(:)) end if - call util_spill_tp(keeps, discards, lspill_list) + call util_copy_spill_tp(keeps, discards, lspill_list) class default write(*,*) 'Error! spill method called for incompatible return type on rmvs_tp' end select end associate return - end subroutine rmvs_util_spill_tp + end subroutine rmvs_util_copy_spill_tp end submodule s_rmvs_util diff --git a/src/util/util_append.f90 b/src/util/util_append.f90 index 3541ed8e3..3a5b3ba81 100644 --- a/src/util/util_append.f90 +++ b/src/util/util_append.f90 @@ -2,7 +2,7 @@ use swiftest contains - module subroutine util_append_body(self, source, param, lmask) + module subroutine util_append_body(self, source, param, lsource_mask) !! author: David A. Minton !! !! Append components from one Swiftest body object to another. @@ -12,7 +12,7 @@ module subroutine util_append_body(self, source, param, lmask) class(swiftest_body), intent(inout) :: self !! Swiftest body object class(swiftest_body), intent(in) :: source !! Source object to append class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - logical, dimension(:), optional, intent(in) :: lmask !! Logical mask indicating which elements to append to + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to associate(nold => self%nbody, nnew => source%nbody) if (nnew > size(self%status)) call self%resize(nnew, param) diff --git a/src/util/util_copy.f90 b/src/util/util_copy.f90 index 4d85e7f0c..ad3c111c4 100644 --- a/src/util/util_copy.f90 +++ b/src/util/util_copy.f90 @@ -2,7 +2,250 @@ use swiftest contains - module subroutine util_copy_into_body(self, source, param, lmask) + module subroutine util_copy_fill_body(self, inserts, lfill_list) + !! author: David A. Minton + !! + !! Insert new Swiftest generic particle structure into an old one. + !! This is the inverse of a fill operation. + implicit none + ! Arguments + class(swiftest_body), intent(inout) :: self !! Swiftest generic 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 + ! 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) + keeps%id(:) = unpack(keeps%id(:), .not.lfill_list(:), keeps%id(:)) + keeps%id(:) = unpack(inserts%id(:), lfill_list(:), keeps%id(:)) + + keeps%name(:) = unpack(keeps%name(:), .not.lfill_list(:), keeps%name(:)) + keeps%name(:) = unpack(inserts%name(:), lfill_list(:), keeps%name(:)) + + keeps%status(:) = unpack(keeps%status(:), .not.lfill_list(:), keeps%status(:)) + keeps%status(:) = unpack(inserts%status(:), lfill_list(:), keeps%status(:)) + + keeps%ldiscard(:) = unpack(keeps%ldiscard(:), .not.lfill_list(:), keeps%ldiscard(:)) + keeps%ldiscard(:) = unpack(inserts%ldiscard(:), lfill_list(:), keeps%ldiscard(:)) + + keeps%mu(:) = unpack(keeps%mu(:), .not.lfill_list(:), keeps%mu(:)) + keeps%mu(:) = unpack(inserts%mu(:), lfill_list(:), keeps%mu(:)) + + keeps%lmask(:) = unpack(keeps%lmask(:), .not.lfill_list(:), keeps%ldiscard(:)) + keeps%lmask(:) = unpack(inserts%lmask(:), lfill_list(:), keeps%ldiscard(:)) + + do i = 1, NDIM + keeps%xh(i, :) = unpack(keeps%xh(i, :), .not.lfill_list(:), keeps%xh(i, :)) + keeps%xh(i, :) = unpack(inserts%xh(i, :), lfill_list(:), keeps%xh(i, :)) + + keeps%vh(i, :) = unpack(keeps%vh(i, :), .not.lfill_list(:), keeps%vh(i, :)) + keeps%vh(i, :) = unpack(inserts%vh(i, :), lfill_list(:), keeps%vh(i, :)) + + keeps%xb(i, :) = unpack(keeps%xb(i, :), .not.lfill_list(:), keeps%xb(i, :)) + keeps%xb(i, :) = unpack(inserts%xb(i, :), lfill_list(:), keeps%xb(i, :)) + + keeps%vb(i, :) = unpack(keeps%vb(i, :), .not.lfill_list(:), keeps%vb(i, :)) + keeps%vb(i, :) = unpack(inserts%vb(i, :), lfill_list(:), keeps%vb(i, :)) + + keeps%ah(i, :) = unpack(keeps%ah(i, :), .not.lfill_list(:), keeps%ah(i, :)) + keeps%ah(i, :) = unpack(inserts%ah(i, :), lfill_list(:), keeps%ah(i, :)) + end do + + if (allocated(keeps%aobl)) then + do i = 1, NDIM + keeps%aobl(i, :) = unpack(keeps%aobl(i, :), .not.lfill_list(:), keeps%aobl(i, :)) + keeps%aobl(i, :) = unpack(inserts%aobl(i, :), lfill_list(:), keeps%aobl(i, :)) + end do + end if + + if (allocated(keeps%agr)) then + do i = 1, NDIM + keeps%agr(i, :) = unpack(keeps%agr(i, :), .not.lfill_list(:), keeps%agr(i, :)) + keeps%agr(i, :) = unpack(inserts%agr(i, :), lfill_list(:), keeps%agr(i, :)) + end do + end if + + if (allocated(keeps%atide)) then + do i = 1, NDIM + keeps%atide(i, :) = unpack(keeps%atide(i, :), .not.lfill_list(:), keeps%atide(i, :)) + keeps%atide(i, :) = unpack(inserts%atide(i, :), lfill_list(:), keeps%atide(i, :)) + end do + end if + + if (allocated(keeps%a)) then + keeps%a(:) = unpack(keeps%a(:), .not.lfill_list(:), keeps%a(:)) + keeps%a(:) = unpack(inserts%a(:), lfill_list(:), keeps%a(:)) + end if + + if (allocated(keeps%e)) then + keeps%e(:) = unpack(keeps%e(:), .not.lfill_list(:), keeps%e(:)) + keeps%e(:) = unpack(inserts%e(:), lfill_list(:), keeps%e(:)) + end if + + if (allocated(keeps%inc)) then + keeps%inc(:) = unpack(keeps%inc(:), .not.lfill_list(:), keeps%inc(:)) + keeps%inc(:) = unpack(inserts%inc(:), lfill_list(:), keeps%inc(:)) + end if + + if (allocated(keeps%capom)) then + keeps%capom(:) = unpack(keeps%capom(:),.not.lfill_list(:), keeps%capom(:)) + keeps%capom(:) = unpack(inserts%capom(:),lfill_list(:), keeps%capom(:)) + end if + + if (allocated(keeps%omega)) then + keeps%omega(:) = unpack(keeps%omega(:),.not.lfill_list(:), keeps%omega(:)) + keeps%omega(:) = unpack(inserts%omega(:),lfill_list(:), keeps%omega(:)) + end if + + if (allocated(keeps%capm)) then + keeps%capm(:) = unpack(keeps%capm(:), .not.lfill_list(:), keeps%capm(:)) + keeps%capm(:) = unpack(inserts%capm(:), lfill_list(:), keeps%capm(:)) + end if + + ! This is the base class, so will be the last to be called in the cascade. + keeps%nbody = size(keeps%id(:)) + end associate + + return + end subroutine util_copy_fill_body + + + module subroutine util_copy_fill_pl(self, inserts, lfill_list) + !! author: David A. Minton + !! + !! Insert new Swiftest massive body structure into an old one. + !! This is the inverse of a fill operation. + implicit none + ! Arguments + 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 + ! Internals + integer(I4B) :: i + + associate(keeps => self) + + 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) + !> Spill components specific to the massive body class + keeps%mass(:) = unpack(keeps%mass(:),.not.lfill_list(:), keeps%mass(:)) + keeps%mass(:) = unpack(inserts%mass(:),lfill_list(:), keeps%mass(:)) + + keeps%Gmass(:) = unpack(keeps%Gmass(:),.not.lfill_list(:), keeps%Gmass(:)) + keeps%Gmass(:) = unpack(inserts%Gmass(:),lfill_list(:), keeps%Gmass(:)) + + keeps%rhill(:) = unpack(keeps%rhill(:),.not.lfill_list(:), keeps%rhill(:)) + keeps%rhill(:) = unpack(inserts%rhill(:),lfill_list(:), keeps%rhill(:)) + + if (allocated(keeps%radius) .and. allocated(inserts%radius)) then + keeps%radius(:) = unpack(keeps%radius(:),.not.lfill_list(:), keeps%radius(:)) + keeps%radius(:) = unpack(inserts%radius(:),lfill_list(:), keeps%radius(:)) + end if + + if (allocated(keeps%density) .and. allocated(inserts%density)) then + keeps%density(:) = unpack(keeps%density(:),.not.lfill_list(:), keeps%density(:)) + keeps%density(:) = unpack(inserts%density(:),lfill_list(:), keeps%density(:)) + end if + + if (allocated(keeps%k2) .and. allocated(inserts%k2)) then + keeps%k2(:) = unpack(keeps%k2(:),.not.lfill_list(:), keeps%k2(:)) + keeps%k2(:) = unpack(inserts%k2(:),lfill_list(:), keeps%k2(:)) + end if + + if (allocated(keeps%Q) .and. allocated(inserts%Q)) then + keeps%Q(:) = unpack(keeps%Q(:),.not.lfill_list(:), keeps%Q(:)) + keeps%Q(:) = unpack(inserts%Q(:),lfill_list(:), keeps%Q(:)) + end if + + if (allocated(keeps%tlag) .and. allocated(inserts%tlag)) then + keeps%tlag(:) = unpack(keeps%tlag(:),.not.lfill_list(:), keeps%tlag(:)) + keeps%tlag(:) = unpack(inserts%tlag(:),lfill_list(:), keeps%tlag(:)) + end if + + if (allocated(keeps%xbeg) .and. allocated(inserts%xbeg)) then + do i = 1, NDIM + keeps%xbeg(i, :) = unpack(keeps%xbeg(i, :), .not.lfill_list(:), keeps%xbeg(i, :)) + keeps%xbeg(i, :) = unpack(inserts%xbeg(i, :), lfill_list(:), keeps%xbeg(i, :)) + end do + end if + + if (allocated(keeps%xend) .and. allocated(inserts%xend)) then + do i = 1, NDIM + keeps%xend(i, :) = unpack(keeps%xend(i, :), .not.lfill_list(:), keeps%xend(i, :)) + keeps%xend(i, :) = unpack(inserts%xend(i, :), lfill_list(:), keeps%xend(i, :)) + end do + end if + + if (allocated(keeps%vbeg) .and. allocated(inserts%vbeg)) then + do i = 1, NDIM + keeps%vbeg(i, :) = unpack(keeps%vbeg(i, :), .not.lfill_list(:), keeps%vbeg(i, :)) + keeps%vbeg(i, :) = unpack(inserts%vbeg(i, :), lfill_list(:), keeps%vbeg(i, :)) + end do + end if + + if (allocated(keeps%Ip) .and. allocated(inserts%Ip)) then + do i = 1, NDIM + keeps%Ip(i, :) = unpack(keeps%Ip(i, :), .not.lfill_list(:), keeps%Ip(i, :)) + keeps%Ip(i, :) = unpack(inserts%Ip(i, :), lfill_list(:), keeps%Ip(i, :)) + end do + end if + + if (allocated(keeps%rot) .and. allocated(inserts%rot)) then + do i = 1, NDIM + keeps%rot(i, :) = unpack(keeps%rot(i, :), .not.lfill_list(:), keeps%rot(i, :)) + keeps%rot(i, :) = unpack(inserts%rot(i, :), lfill_list(:), keeps%rot(i, :)) + end do + end if + + keeps%ldiscard(:) = unpack(inserts%ldiscard(:), lfill_list(:), keeps%ldiscard(:)) + + call util_copy_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 + + + module subroutine util_copy_fill_tp(self, inserts, lfill_list) + !! author: David A. Minton + !! + !! Insert new Swiftest test particle structure into an old one. + !! This is the inverse of a fill operation. + implicit none + ! Arguments + 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 + + associate(keeps => self) + select type(inserts) + class is (swiftest_tp) + !> Spill components specific to the test particle class + keeps%isperi(:) = unpack(keeps%isperi(:), .not.lfill_list(:), keeps%isperi(:)) + keeps%isperi(:) = unpack(inserts%isperi(:), lfill_list(:), keeps%isperi(:)) + + keeps%peri(:) = unpack(keeps%peri(:), .not.lfill_list(:), keeps%peri(:)) + keeps%peri(:) = unpack(inserts%peri(:), lfill_list(:), keeps%peri(:)) + + keeps%atp(:) = unpack(keeps%atp(:), .not.lfill_list(:), keeps%atp(:)) + keeps%atp(:) = unpack(inserts%atp(:), lfill_list(:), keeps%atp(:)) + + call util_copy_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 + + + module subroutine util_copy_into_body(self, source, param, lsource_mask) !! author: David A. Minton !! !! Copies elements from one Swiftest body object to another. @@ -12,20 +255,277 @@ module subroutine util_copy_into_body(self, source, param, lmask) class(swiftest_body), intent(inout) :: self !! Swiftest body object class(swiftest_body), intent(in) :: source !! Source object to append class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - logical, dimension(:), optional, intent(in) :: lmask !! Logical mask indicating which elements to append to + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to ! Internals - integer(I4B) :: nnew + integer(I4B) :: i,nnew + logical, dimension(:), allocatable :: lfill_list - if (present(lmask)) then - nnew = count(lmask) + if (present(lsource_mask)) then + nnew = count(lsource_mask) else nnew = size(source%status) end if + allocate(lfill_list(size(self%status))) + lfill_list = .false. + lfill_list(1:nnew) = .true. associate(nold => self%nbody) if (nnew > size(self%status)) call self%resize(nnew, param) - + call self%fill(source, lfill_list) end associate 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_spill_and_fill.f90 b/src/util/util_spill_and_fill.f90 deleted file mode 100644 index 89f8bb095..000000000 --- a/src/util/util_spill_and_fill.f90 +++ /dev/null @@ -1,506 +0,0 @@ -submodule (swiftest_classes) s_util_spill_and_fill - use swiftest -contains - - module subroutine util_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_spill_body - - - module subroutine util_fill_body(self, inserts, lfill_list) - !! author: David A. Minton - !! - !! Insert new Swiftest generic particle structure into an old one. - !! This is the inverse of a fill operation. - implicit none - ! Arguments - class(swiftest_body), intent(inout) :: self !! Swiftest generic body object - class(swiftest_body), intent(inout) :: inserts !! Insertted object - logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - ! 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) - keeps%id(:) = unpack(keeps%id(:), .not.lfill_list(:), keeps%id(:)) - keeps%id(:) = unpack(inserts%id(:), lfill_list(:), keeps%id(:)) - - keeps%name(:) = unpack(keeps%name(:), .not.lfill_list(:), keeps%name(:)) - keeps%name(:) = unpack(inserts%name(:), lfill_list(:), keeps%name(:)) - - keeps%status(:) = unpack(keeps%status(:), .not.lfill_list(:), keeps%status(:)) - keeps%status(:) = unpack(inserts%status(:), lfill_list(:), keeps%status(:)) - - keeps%ldiscard(:) = unpack(keeps%ldiscard(:), .not.lfill_list(:), keeps%ldiscard(:)) - keeps%ldiscard(:) = unpack(inserts%ldiscard(:), lfill_list(:), keeps%ldiscard(:)) - - keeps%mu(:) = unpack(keeps%mu(:), .not.lfill_list(:), keeps%mu(:)) - keeps%mu(:) = unpack(inserts%mu(:), lfill_list(:), keeps%mu(:)) - - keeps%lmask(:) = unpack(keeps%lmask(:), .not.lfill_list(:), keeps%ldiscard(:)) - keeps%lmask(:) = unpack(inserts%lmask(:), lfill_list(:), keeps%ldiscard(:)) - - do i = 1, NDIM - keeps%xh(i, :) = unpack(keeps%xh(i, :), .not.lfill_list(:), keeps%xh(i, :)) - keeps%xh(i, :) = unpack(inserts%xh(i, :), lfill_list(:), keeps%xh(i, :)) - - keeps%vh(i, :) = unpack(keeps%vh(i, :), .not.lfill_list(:), keeps%vh(i, :)) - keeps%vh(i, :) = unpack(inserts%vh(i, :), lfill_list(:), keeps%vh(i, :)) - - keeps%xb(i, :) = unpack(keeps%xb(i, :), .not.lfill_list(:), keeps%xb(i, :)) - keeps%xb(i, :) = unpack(inserts%xb(i, :), lfill_list(:), keeps%xb(i, :)) - - keeps%vb(i, :) = unpack(keeps%vb(i, :), .not.lfill_list(:), keeps%vb(i, :)) - keeps%vb(i, :) = unpack(inserts%vb(i, :), lfill_list(:), keeps%vb(i, :)) - - keeps%ah(i, :) = unpack(keeps%ah(i, :), .not.lfill_list(:), keeps%ah(i, :)) - keeps%ah(i, :) = unpack(inserts%ah(i, :), lfill_list(:), keeps%ah(i, :)) - end do - - if (allocated(keeps%aobl)) then - do i = 1, NDIM - keeps%aobl(i, :) = unpack(keeps%aobl(i, :), .not.lfill_list(:), keeps%aobl(i, :)) - keeps%aobl(i, :) = unpack(inserts%aobl(i, :), lfill_list(:), keeps%aobl(i, :)) - end do - end if - - if (allocated(keeps%agr)) then - do i = 1, NDIM - keeps%agr(i, :) = unpack(keeps%agr(i, :), .not.lfill_list(:), keeps%agr(i, :)) - keeps%agr(i, :) = unpack(inserts%agr(i, :), lfill_list(:), keeps%agr(i, :)) - end do - end if - - if (allocated(keeps%atide)) then - do i = 1, NDIM - keeps%atide(i, :) = unpack(keeps%atide(i, :), .not.lfill_list(:), keeps%atide(i, :)) - keeps%atide(i, :) = unpack(inserts%atide(i, :), lfill_list(:), keeps%atide(i, :)) - end do - end if - - if (allocated(keeps%a)) then - keeps%a(:) = unpack(keeps%a(:), .not.lfill_list(:), keeps%a(:)) - keeps%a(:) = unpack(inserts%a(:), lfill_list(:), keeps%a(:)) - end if - - if (allocated(keeps%e)) then - keeps%e(:) = unpack(keeps%e(:), .not.lfill_list(:), keeps%e(:)) - keeps%e(:) = unpack(inserts%e(:), lfill_list(:), keeps%e(:)) - end if - - if (allocated(keeps%inc)) then - keeps%inc(:) = unpack(keeps%inc(:), .not.lfill_list(:), keeps%inc(:)) - keeps%inc(:) = unpack(inserts%inc(:), lfill_list(:), keeps%inc(:)) - end if - - if (allocated(keeps%capom)) then - keeps%capom(:) = unpack(keeps%capom(:),.not.lfill_list(:), keeps%capom(:)) - keeps%capom(:) = unpack(inserts%capom(:),lfill_list(:), keeps%capom(:)) - end if - - if (allocated(keeps%omega)) then - keeps%omega(:) = unpack(keeps%omega(:),.not.lfill_list(:), keeps%omega(:)) - keeps%omega(:) = unpack(inserts%omega(:),lfill_list(:), keeps%omega(:)) - end if - - if (allocated(keeps%capm)) then - keeps%capm(:) = unpack(keeps%capm(:), .not.lfill_list(:), keeps%capm(:)) - keeps%capm(:) = unpack(inserts%capm(:), lfill_list(:), keeps%capm(:)) - end if - - ! This is the base class, so will be the last to be called in the cascade. - keeps%nbody = size(keeps%id(:)) - end associate - - return - end subroutine util_fill_body - - - module subroutine util_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_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_spill_pl - - - module subroutine util_fill_pl(self, inserts, lfill_list) - !! author: David A. Minton - !! - !! Insert new Swiftest massive body structure into an old one. - !! This is the inverse of a fill operation. - implicit none - ! Arguments - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_body), intent(inout) :: inserts !! Swiftest body object to be inserted - logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - ! Internals - integer(I4B) :: i - - associate(keeps => self) - - 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) - !> Spill components specific to the massive body class - keeps%mass(:) = unpack(keeps%mass(:),.not.lfill_list(:), keeps%mass(:)) - keeps%mass(:) = unpack(inserts%mass(:),lfill_list(:), keeps%mass(:)) - - keeps%Gmass(:) = unpack(keeps%Gmass(:),.not.lfill_list(:), keeps%Gmass(:)) - keeps%Gmass(:) = unpack(inserts%Gmass(:),lfill_list(:), keeps%Gmass(:)) - - keeps%rhill(:) = unpack(keeps%rhill(:),.not.lfill_list(:), keeps%rhill(:)) - keeps%rhill(:) = unpack(inserts%rhill(:),lfill_list(:), keeps%rhill(:)) - - if (allocated(keeps%radius) .and. allocated(inserts%radius)) then - keeps%radius(:) = unpack(keeps%radius(:),.not.lfill_list(:), keeps%radius(:)) - keeps%radius(:) = unpack(inserts%radius(:),lfill_list(:), keeps%radius(:)) - end if - - if (allocated(keeps%density) .and. allocated(inserts%density)) then - keeps%density(:) = unpack(keeps%density(:),.not.lfill_list(:), keeps%density(:)) - keeps%density(:) = unpack(inserts%density(:),lfill_list(:), keeps%density(:)) - end if - - if (allocated(keeps%k2) .and. allocated(inserts%k2)) then - keeps%k2(:) = unpack(keeps%k2(:),.not.lfill_list(:), keeps%k2(:)) - keeps%k2(:) = unpack(inserts%k2(:),lfill_list(:), keeps%k2(:)) - end if - - if (allocated(keeps%Q) .and. allocated(inserts%Q)) then - keeps%Q(:) = unpack(keeps%Q(:),.not.lfill_list(:), keeps%Q(:)) - keeps%Q(:) = unpack(inserts%Q(:),lfill_list(:), keeps%Q(:)) - end if - - if (allocated(keeps%tlag) .and. allocated(inserts%tlag)) then - keeps%tlag(:) = unpack(keeps%tlag(:),.not.lfill_list(:), keeps%tlag(:)) - keeps%tlag(:) = unpack(inserts%tlag(:),lfill_list(:), keeps%tlag(:)) - end if - - if (allocated(keeps%xbeg) .and. allocated(inserts%xbeg)) then - do i = 1, NDIM - keeps%xbeg(i, :) = unpack(keeps%xbeg(i, :), .not.lfill_list(:), keeps%xbeg(i, :)) - keeps%xbeg(i, :) = unpack(inserts%xbeg(i, :), lfill_list(:), keeps%xbeg(i, :)) - end do - end if - - if (allocated(keeps%xend) .and. allocated(inserts%xend)) then - do i = 1, NDIM - keeps%xend(i, :) = unpack(keeps%xend(i, :), .not.lfill_list(:), keeps%xend(i, :)) - keeps%xend(i, :) = unpack(inserts%xend(i, :), lfill_list(:), keeps%xend(i, :)) - end do - end if - - if (allocated(keeps%vbeg) .and. allocated(inserts%vbeg)) then - do i = 1, NDIM - keeps%vbeg(i, :) = unpack(keeps%vbeg(i, :), .not.lfill_list(:), keeps%vbeg(i, :)) - keeps%vbeg(i, :) = unpack(inserts%vbeg(i, :), lfill_list(:), keeps%vbeg(i, :)) - end do - end if - - if (allocated(keeps%Ip) .and. allocated(inserts%Ip)) then - do i = 1, NDIM - keeps%Ip(i, :) = unpack(keeps%Ip(i, :), .not.lfill_list(:), keeps%Ip(i, :)) - keeps%Ip(i, :) = unpack(inserts%Ip(i, :), lfill_list(:), keeps%Ip(i, :)) - end do - end if - - if (allocated(keeps%rot) .and. allocated(inserts%rot)) then - do i = 1, NDIM - keeps%rot(i, :) = unpack(keeps%rot(i, :), .not.lfill_list(:), keeps%rot(i, :)) - keeps%rot(i, :) = unpack(inserts%rot(i, :), lfill_list(:), keeps%rot(i, :)) - end do - end if - - keeps%ldiscard(:) = unpack(inserts%ldiscard(:), lfill_list(:), keeps%ldiscard(:)) - - 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_fill_pl - - - module subroutine util_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_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_spill_tp - - - module subroutine util_fill_tp(self, inserts, lfill_list) - !! author: David A. Minton - !! - !! Insert new Swiftest test particle structure into an old one. - !! This is the inverse of a fill operation. - implicit none - ! Arguments - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - class(swiftest_body), intent(inout) :: inserts !! Swiftest body object to be inserted - logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - - associate(keeps => self) - select type(inserts) - class is (swiftest_tp) - !> Spill components specific to the test particle class - keeps%isperi(:) = unpack(keeps%isperi(:), .not.lfill_list(:), keeps%isperi(:)) - keeps%isperi(:) = unpack(inserts%isperi(:), lfill_list(:), keeps%isperi(:)) - - keeps%peri(:) = unpack(keeps%peri(:), .not.lfill_list(:), keeps%peri(:)) - keeps%peri(:) = unpack(inserts%peri(:), lfill_list(:), keeps%peri(:)) - - keeps%atp(:) = unpack(keeps%atp(:), .not.lfill_list(:), keeps%atp(:)) - keeps%atp(:) = unpack(inserts%atp(:), lfill_list(:), keeps%atp(:)) - - 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_fill_tp - -end submodule s_util_spill_and_fill - - - - - - diff --git a/src/whm/whm_util.f90 b/src/whm/whm_util.f90 index 779480b3f..aaad01e84 100644 --- a/src/whm/whm_util.f90 +++ b/src/whm/whm_util.f90 @@ -2,7 +2,7 @@ use swiftest contains - module subroutine whm_util_spill_pl(self, discards, lspill_list) + module subroutine whm_util_copy_spill_pl(self, discards, lspill_list) !! author: David A. Minton !! !! Move spilled (discarded) WHM test particle structure from active list to discard list @@ -35,17 +35,17 @@ module subroutine whm_util_spill_pl(self, discards, lspill_list) keeps%vj(i, :) = pack(keeps%vj(i, :), .not. lspill_list(:)) end do end if - call util_spill_pl(keeps, discards, lspill_list) + call util_copy_spill_pl(keeps, discards, lspill_list) class default write(*,*) 'Error! spill method called for incompatible return type on whm_pl' end select end associate return - end subroutine whm_util_spill_pl + end subroutine whm_util_copy_spill_pl - module subroutine whm_util_fill_pl(self, inserts, lfill_list) + module subroutine whm_util_copy_fill_pl(self, inserts, lfill_list) !! author: David A. Minton !! !! Insert new WHM test particle structure into an old one. @@ -55,7 +55,7 @@ module subroutine whm_util_fill_pl(self, inserts, lfill_list) implicit none ! Arguments class(whm_pl), intent(inout) :: self !! WHM massive body object - class(swiftest_body), intent(inout) :: inserts !! inserted object + class(swiftest_body), intent(in) :: inserts !! inserted object logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps ! Internals integer(I4B) :: i @@ -80,14 +80,14 @@ module subroutine whm_util_fill_pl(self, inserts, lfill_list) keeps%vj(i, :) = unpack(keeps%vj(i, :), .not.lfill_list(:), keeps%vj(i, :)) keeps%vj(i, :) = unpack(inserts%vj(i, :), lfill_list(:), keeps%vj(i, :)) end do - call util_fill_pl(keeps, inserts, lfill_list) + call util_copy_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_fill_pl + end subroutine whm_util_copy_fill_pl module subroutine whm_util_set_ir3j(self)