From f4bce42975db7d9a27f6040dfbe42e2d980f86e3 Mon Sep 17 00:00:00 2001 From: David Minton Date: Mon, 2 Aug 2021 12:16:05 -0400 Subject: [PATCH] Added append methods to all body types --- src/modules/rmvs_classes.f90 | 18 +++ src/modules/swiftest_classes.f90 | 52 ++++++--- src/modules/symba_classes.f90 | 40 ++++++- src/modules/whm_classes.f90 | 27 +++-- src/rmvs/rmvs_util.f90 | 69 +++++++++++- src/symba/symba_util.f90 | 144 +++++++++++++++++++++++- src/util/util_append.f90 | 182 ++++++++++++++++++++++++------- src/util/util_exit.f90 | 1 + src/whm/whm_util.f90 | 85 ++++++++++----- 9 files changed, 514 insertions(+), 104 deletions(-) diff --git a/src/modules/rmvs_classes.f90 b/src/modules/rmvs_classes.f90 index 49794b1ef..315b098a8 100644 --- a/src/modules/rmvs_classes.f90 +++ b/src/modules/rmvs_classes.f90 @@ -71,6 +71,7 @@ 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 :: append => rmvs_util_append_tp !! Appends elements from one structure to another 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 :: resize => rmvs_util_resize_tp !! Checks the current size of a Swiftest body against the requested size and resizes it if it is too small. procedure :: sort => rmvs_util_sort_tp !! Sorts body arrays by a sortable componen @@ -93,6 +94,7 @@ module rmvs_classes logical :: lplanetocentric = .false. !! Flag that indicates that the object is a planetocentric set of masive bodies used for close encounter calculations contains procedure :: setup => rmvs_setup_pl !! Constructor method - Allocates space for number of particles + procedure :: append => rmvs_util_append_pl !! Appends elements from one structure to another 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 :: resize => rmvs_util_resize_pl !! Checks the current size of a Swiftest body against the requested size and resizes it if it is too small. procedure :: sort => rmvs_util_sort_pl !! Sorts body arrays by a sortable componen @@ -156,6 +158,22 @@ 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_append_pl(self, source, lsource_mask) + use swiftest_classes, only : swiftest_body + implicit none + class(rmvs_pl), intent(inout) :: self !! RMVS massive body object + class(swiftest_body), intent(in) :: source !! Source object to append + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + end subroutine rmvs_util_append_pl + + module subroutine rmvs_util_append_tp(self, source, lsource_mask) + use swiftest_classes, only : swiftest_body + implicit none + class(rmvs_tp), intent(inout) :: self !! RMVS test particle object + class(swiftest_body), intent(in) :: source !! Source object to append + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + end subroutine rmvs_util_append_tp + module subroutine rmvs_util_fill_pl(self, inserts, lfill_list) use swiftest_classes, only : swiftest_body implicit none diff --git a/src/modules/swiftest_classes.f90 b/src/modules/swiftest_classes.f90 index 7501d730c..c7a7939a1 100644 --- a/src/modules/swiftest_classes.f90 +++ b/src/modules/swiftest_classes.f90 @@ -205,6 +205,7 @@ module swiftest_classes procedure :: accel_obl => obl_acc_pl !! Compute the barycentric accelerations of bodies due to the oblateness of the central body procedure :: setup => setup_pl !! A base constructor that sets the number of bodies and allocates and initializes all arrays procedure :: accel_tides => tides_kick_getacch_pl !! Compute the accelerations of bodies due to tidal interactions with the central body + procedure :: append => util_append_pl !! Appends elements from one structure to another 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 UNPACK intrinsic) @@ -231,19 +232,20 @@ module swiftest_classes contains ! Test particle-specific concrete methods ! These are concrete because they are the same implemenation for all integrators - procedure :: discard => discard_tp !! Check to see if test particles should be discarded based on their positions relative to the massive bodies - procedure :: accel_int => kick_getacch_int_tp !! Compute direct cross (third) term heliocentric accelerations of test particles by massive bodies - procedure :: accel_obl => obl_acc_tp !! Compute the barycentric accelerations of bodies due to the oblateness of the central body - 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 UNPACK intrinsic) - procedure :: get_peri => util_peri_tp !! Determine system pericenter passages for test particles - procedure :: resize => util_resize_tp !! Checks the current size of a Swiftest body against the requested size and resizes it if it is too small. - 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 :: discard => discard_tp !! Check to see if test particles should be discarded based on their positions relative to the massive bodies + procedure :: accel_int => kick_getacch_int_tp !! Compute direct cross (third) term heliocentric accelerations of test particles by massive bodies + procedure :: accel_obl => obl_acc_tp !! Compute the barycentric accelerations of bodies due to the oblateness of the central body + procedure :: setup => setup_tp !! A base constructor that sets the number of bodies and + procedure :: append => util_append_tp !! Appends elements from one structure to another + 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 UNPACK intrinsic) + procedure :: get_peri => util_peri_tp !! Determine system pericenter passages for test particles + procedure :: resize => util_resize_tp !! Checks the current size of a Swiftest body against the requested size and resizes it if it is too small. + 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) end type swiftest_tp !******************************************************************************************************************************** @@ -742,35 +744,35 @@ end subroutine user_kick_getacch_body module subroutine util_append_arr_char_string(arr, source, lsource_mask) implicit none character(len=STRMAX), dimension(:), allocatable, intent(inout) :: arr !! Destination array - character(len=STRMAX), dimension(:), allocatable, intent(inout) :: source !! Array to append + character(len=STRMAX), dimension(:), allocatable, intent(in) :: source !! Array to append logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to end subroutine util_append_arr_char_string module subroutine util_append_arr_DP(arr, source, lsource_mask) implicit none real(DP), dimension(:), allocatable, intent(inout) :: arr !! Destination array - real(DP), dimension(:), allocatable, intent(inout) :: source !! Array to append + real(DP), dimension(:), allocatable, intent(in) :: source !! Array to append logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to end subroutine util_append_arr_DP module subroutine util_append_arr_DPvec(arr, source, lsource_mask) implicit none real(DP), dimension(:,:), allocatable, intent(inout) :: arr !! Destination array - real(DP), dimension(:,:), allocatable, intent(inout) :: source !! Array to append + real(DP), dimension(:,:), allocatable, intent(in) :: source !! Array to append logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to end subroutine util_append_arr_DPvec module subroutine util_append_arr_I4B(arr, source, lsource_mask) implicit none integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), allocatable, intent(inout) :: source !! Array to append + integer(I4B), dimension(:), allocatable, intent(in) :: source !! Array to append logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to end subroutine util_append_arr_I4B module subroutine util_append_arr_logical(arr, source, lsource_mask) implicit none logical, dimension(:), allocatable, intent(inout) :: arr !! Destination array - logical, dimension(:), allocatable, intent(inout) :: source !! Array to append + logical, dimension(:), allocatable, intent(in) :: source !! Array to append logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to end subroutine util_append_arr_logical end interface @@ -783,6 +785,20 @@ module subroutine util_append_body(self, source, lsource_mask) logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to end subroutine util_append_body + module subroutine util_append_pl(self, source, lsource_mask) + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_body), intent(in) :: source !! Source object to append + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + end subroutine util_append_pl + + module subroutine util_append_tp(self, source, lsource_mask) + implicit none + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + class(swiftest_body), intent(in) :: source !! Source object to append + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + end subroutine util_append_tp + module subroutine util_coord_b2h_pl(self, cb) implicit none class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object diff --git a/src/modules/symba_classes.f90 b/src/modules/symba_classes.f90 index 712b98f65..01af9a48f 100644 --- a/src/modules/symba_classes.f90 +++ b/src/modules/symba_classes.f90 @@ -92,6 +92,7 @@ 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 :: append => symba_util_append_pl !! Appends elements from one structure to another 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 :: resize => symba_util_resize_pl !! Checks the current size of a Swiftest body against the requested size and resizes it if it is too small. procedure :: sort => symba_util_sort_pl !! Sorts body arrays by a sortable componen @@ -112,6 +113,7 @@ 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 :: append => symba_util_append_tp !! Appends elements from one structure to another 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 :: resize => symba_util_resize_tp !! Checks the current size of a Swiftest body against the requested size and resizes it if it is too small. procedure :: sort => symba_util_sort_tp !! Sorts body arrays by a sortable componen @@ -419,6 +421,40 @@ module subroutine symba_step_reset_system(self) implicit none class(symba_nbody_system), intent(inout) :: self !! SyMBA nbody system object end subroutine symba_step_reset_system + end interface + + interface util_append + module subroutine symba_util_append_arr_info(arr, source, lsource_mask) + implicit none + type(symba_particle_info), dimension(:), allocatable, intent(inout) :: arr !! Destination array + type(symba_particle_info), dimension(:), allocatable, intent(in) :: source !! Array to append + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + end subroutine symba_util_append_arr_info + + module subroutine symba_util_append_arr_kin(arr, source, lsource_mask) + implicit none + type(symba_kinship), dimension(:), allocatable, intent(inout) :: arr !! Destination array + type(symba_kinship), dimension(:), allocatable, intent(in) :: source !! Array to append + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + end subroutine symba_util_append_arr_kin + end interface + + interface + module subroutine symba_util_append_pl(self, source, lsource_mask) + use swiftest_classes, only : swiftest_body + implicit none + class(symba_pl), intent(inout) :: self !! SyMBA massive body object + class(swiftest_body), intent(in) :: source !! Source object to append + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + end subroutine symba_util_append_pl + + module subroutine symba_util_append_tp(self, source, lsource_mask) + use swiftest_classes, only : swiftest_body + implicit none + class(symba_tp), intent(inout) :: self !! SyMBA test particle object + class(swiftest_body), intent(in) :: source !! Source object to append + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + end subroutine symba_util_append_tp module subroutine symba_util_copy_pltpenc(self, source) implicit none @@ -434,12 +470,12 @@ end subroutine symba_util_copy_plplenc end interface interface util_fill - module subroutine symba_util_fill_arr_char_info(keeps, inserts, lfill_list) + module subroutine symba_util_fill_arr_info(keeps, inserts, lfill_list) implicit none type(symba_particle_info), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep type(symba_particle_info), dimension(:), allocatable, intent(in) :: inserts !! Array of values to insert into keep logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - end subroutine symba_util_fill_arr_char_info + end subroutine symba_util_fill_arr_info module subroutine symba_util_fill_arr_kin(keeps, inserts, lfill_list) implicit none diff --git a/src/modules/whm_classes.f90 b/src/modules/whm_classes.f90 index 0f67c9432..e581e52b1 100644 --- a/src/modules/whm_classes.f90 +++ b/src/modules/whm_classes.f90 @@ -38,6 +38,7 @@ module whm_classes procedure :: gr_pos_kick => whm_gr_p4_pl !! Position kick due to p**4 term in the post-Newtonian correction 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 :: append => whm_util_append_pl !! Appends elements from one structure to another 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 :: resize => whm_util_resize_pl !! Checks the current size of a Swiftest body against the requested size and resizes it if it is too small. procedure :: set_ir3 => whm_util_set_ir3j !! Sets both the heliocentric and jacobi inverse radius terms (1/rj**3 and 1/rh**3) @@ -207,6 +208,15 @@ module subroutine whm_step_pl(self, system, param, t, dt) real(DP), intent(in) :: dt !! Current stepsize end subroutine whm_step_pl + module subroutine whm_step_system(self, param, t, dt) + use swiftest_classes, only : swiftest_parameters + implicit none + class(whm_nbody_system), intent(inout) :: self !! WHM system object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + real(DP), intent(in) :: t !! Simulation time + real(DP), intent(in) :: dt !! Current stepsize + end subroutine whm_step_system + module subroutine whm_step_tp(self, system, param, t, dt) use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters implicit none @@ -217,6 +227,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_append_pl(self, source, lsource_mask) + use swiftest_classes, only : swiftest_body + implicit none + class(whm_pl), intent(inout) :: self !! WHM massive body object + class(swiftest_body), intent(in) :: source !! Source object to append + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + end subroutine whm_util_append_pl + module subroutine whm_util_spill_pl(self, discards, lspill_list, ldestructive) use swiftest_classes, only : swiftest_body implicit none @@ -226,15 +244,6 @@ module subroutine whm_util_spill_pl(self, discards, lspill_list, ldestructive) 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 - module subroutine whm_step_system(self, param, t, dt) - use swiftest_classes, only : swiftest_parameters - implicit none - class(whm_nbody_system), intent(inout) :: self !! WHM system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - real(DP), intent(in) :: t !! Simulation time - real(DP), intent(in) :: dt !! Current stepsize - end subroutine whm_step_system - module subroutine whm_util_fill_pl(self, inserts, lfill_list) use swiftest_classes, only : swiftest_body implicit none diff --git a/src/rmvs/rmvs_util.f90 b/src/rmvs/rmvs_util.f90 index dcf0de473..8f0d7cf5d 100644 --- a/src/rmvs/rmvs_util.f90 +++ b/src/rmvs/rmvs_util.f90 @@ -2,6 +2,66 @@ use swiftest contains + module subroutine rmvs_util_append_pl(self, source, lsource_mask) + !! author: David A. Minton + !! + !! Append components from one massive body object to another. + !! This method will automatically resize the destination body if it is too small + implicit none + !! Arguments + class(rmvs_pl), intent(inout) :: self !! RMVS massive body object + class(swiftest_body), intent(in) :: source !! Source object to append + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + + select type(source) + class is (rmvs_pl) + call util_append(self%nenc, source%nenc, lsource_mask) + call util_append(self%tpenc1P, source%tpenc1P, lsource_mask) + call util_append(self%plind, source%plind, lsource_mask) + + ! The following are not implemented as RMVS doesn't make use of fill operations on pl type + ! So they are here as a placeholder in case someone wants to extend the RMVS class for some reason + !call util_append(self%outer, source%outer, lsource_mask) + !call util_append(self%inner, source%inner, lsource_mask) + !call util_append(self%planetocentric, source%planetocentric, lsource_mask) + + call whm_util_append_pl(self, source, lsource_mask) + class default + write(*,*) "Invalid object passed to the append method. Source must be of class rmvs_pl or its descendents" + call util_exit(FAILURE) + end select + + return + end subroutine rmvs_util_append_pl + + + module subroutine rmvs_util_append_tp(self, source, lsource_mask) + !! author: David A. Minton + !! + !! Append components from test particle object to another. + !! This method will automatically resize the destination body if it is too small + implicit none + !! Arguments + class(rmvs_tp), intent(inout) :: self !! RMVS test particle object + class(swiftest_body), intent(in) :: source !! Source object to append + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + + select type(source) + class is (rmvs_tp) + call util_append(self%lperi, source%lperi, lsource_mask) + call util_append(self%plperP, source%plperP, lsource_mask) + call util_append(self%plencP, source%plencP, lsource_mask) + + call util_append_tp(self, source, lsource_mask) ! Note: whm_tp does not have its own append method, so we skip back to the base class + class default + write(*,*) "Invalid object passed to the append method. Source must be of class rmvs_tp or its descendents" + call util_exit(FAILURE) + end select + + return + end subroutine rmvs_util_append_tp + + module subroutine rmvs_util_fill_pl(self, inserts, lfill_list) !! author: David A. Minton !! @@ -19,11 +79,16 @@ module subroutine rmvs_util_fill_pl(self, inserts, lfill_list) associate(keeps => self) select type(inserts) class is (rmvs_pl) - call util_fill(keeps%nenc, inserts%nenc, lfill_list) call util_fill(keeps%tpenc1P, inserts%tpenc1P, lfill_list) call util_fill(keeps%plind, inserts%plind, lfill_list) + ! The following are not implemented as RMVS doesn't make use of fill operations on pl type + ! So they are here as a placeholder in case someone wants to extend the RMVS class for some reason + !call util_fill(keeps%outer, inserts%outer, lfill_list) + !call util_fill(keeps%inner, inserts%inner, lfill_list) + !call util_fill(keeps%planetocentric, inserts%planetocentric, lfill_list) + call whm_util_fill_pl(keeps, inserts, lfill_list) class default write(*,*) 'Error! spill method called for incompatible return type on rmvs_pl' @@ -53,7 +118,7 @@ module subroutine rmvs_util_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_fill_tp(keeps, inserts, lfill_list) + call util_fill_tp(keeps, inserts, lfill_list) ! Note: whm_tp does not have its own fill method, so we skip back to the base class class default write(*,*) 'Error! fill method called for incompatible return type on rmvs_tp' end select diff --git a/src/symba/symba_util.f90 b/src/symba/symba_util.f90 index f2f72d12d..02d839bb2 100644 --- a/src/symba/symba_util.f90 +++ b/src/symba/symba_util.f90 @@ -2,6 +2,142 @@ use swiftest contains + module subroutine symba_util_append_arr_info(arr, source, lsource_mask) + !! author: David A. Minton + !! + !! Append a single array of particle information type onto another. If the destination array is not allocated, or is not big enough, this will allocate space for it. + implicit none + ! Arguments + type(symba_particle_info), dimension(:), allocatable, intent(inout) :: arr !! Destination array + type(symba_particle_info), dimension(:), allocatable, intent(in) :: source !! Array to append + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + ! Internals + integer(I4B) :: narr, nsrc + + if (.not. allocated(source)) return + + if (present(lsource_mask)) then + nsrc = count(lsource_mask) + else + nsrc = size(source) + end if + + if (allocated(arr)) then + narr = size(arr) + else + allocate(arr(nsrc)) + narr = 0 + end if + + if (present(lsource_mask)) then + arr(narr+1:nsrc) = pack(source(:), lsource_mask(:)) + else + arr(narr+1:nsrc) = source(:) + end if + + return + end subroutine symba_util_append_arr_info + + + module subroutine symba_util_append_arr_kin(arr, source, lsource_mask) + !! author: David A. Minton + !! + !! Append a single array of kinship type onto another. If the destination array is not allocated, or is not big enough, this will allocate space for it. + implicit none + ! Arguments + type(symba_kinship), dimension(:), allocatable, intent(inout) :: arr !! Destination array + type(symba_kinship), dimension(:), allocatable, intent(in) :: source !! Array to append + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + ! Internals + integer(I4B) :: narr, nsrc + + if (.not. allocated(source)) return + + if (present(lsource_mask)) then + nsrc = count(lsource_mask) + else + nsrc = size(source) + end if + + if (allocated(arr)) then + narr = size(arr) + else + allocate(arr(nsrc)) + narr = 0 + end if + + if (present(lsource_mask)) then + arr(narr+1:nsrc) = pack(source(:), lsource_mask(:)) + else + arr(narr+1:nsrc) = source(:) + end if + + return + end subroutine symba_util_append_arr_kin + + + module subroutine symba_util_append_pl(self, source, lsource_mask) + !! author: David A. Minton + !! + !! Append components from one massive body object to another. + !! This method will automatically resize the destination body if it is too small + implicit none + !! Arguments + class(symba_pl), intent(inout) :: self !! SyMBA massive body object + class(swiftest_body), intent(in) :: source !! Source object to append + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + + select type(source) + class is (symba_pl) + call util_append(self%lcollision, source%lcollision, lsource_mask) + call util_append(self%lencounter, source%lencounter, lsource_mask) + call util_append(self%lmtiny, source%lmtiny, lsource_mask) + call util_append(self%nplenc, source%nplenc, lsource_mask) + call util_append(self%ntpenc, source%ntpenc, lsource_mask) + call util_append(self%levelg, source%levelg, lsource_mask) + call util_append(self%levelm, source%levelm, lsource_mask) + call util_append(self%isperi, source%isperi, lsource_mask) + call util_append(self%peri, source%peri, lsource_mask) + call util_append(self%atp, source%atp, lsource_mask) + call util_append(self%kin, source%kin, lsource_mask) + call util_append(self%info, source%info, lsource_mask) + + call util_append_pl(self, source, lsource_mask) ! Note: helio_pl does not have its own append method, so we skip back to the base class + class default + write(*,*) "Invalid object passed to the append method. Source must be of class symba_pl or its descendents" + call util_exit(FAILURE) + end select + + return + end subroutine symba_util_append_pl + + + module subroutine symba_util_append_tp(self, source, lsource_mask) + !! author: David A. Minton + !! + !! Append components from test particle object to another. + !! This method will automatically resize the destination body if it is too small + implicit none + !! Arguments + class(symba_tp), intent(inout) :: self !! SyMBA test particle object + class(swiftest_body), intent(in) :: source !! Source object to append + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + + select type(source) + class is (symba_tp) + call util_append(self%nplenc, source%nplenc, lsource_mask) + call util_append(self%levelg, source%levelg, lsource_mask) + call util_append(self%levelm, source%levelm, lsource_mask) + + call util_append_tp(self, source, lsource_mask) ! Note: helio_tp does not have its own append method, so we skip back to the base class + class default + write(*,*) "Invalid object passed to the append method. Source must be of class symba_tp or its descendents" + call util_exit(FAILURE) + end select + + return + end subroutine symba_util_append_tp + module subroutine symba_util_copy_pltpenc(self, source) !! author: David A. Minton !! @@ -48,7 +184,7 @@ module subroutine symba_util_copy_plplenc(self, source) end subroutine symba_util_copy_plplenc - module subroutine symba_util_fill_arr_char_info(keeps, inserts, lfill_list) + module subroutine symba_util_fill_arr_info(keeps, inserts, lfill_list) !! author: David A. Minton !! !! Performs a fill operation on a single array of particle origin information types @@ -65,7 +201,7 @@ module subroutine symba_util_fill_arr_char_info(keeps, inserts, lfill_list) keeps(:) = unpack(inserts(:), lfill_list(:), keeps(:)) return - end subroutine symba_util_fill_arr_char_info + end subroutine symba_util_fill_arr_info module subroutine symba_util_fill_arr_kin(keeps, inserts, lfill_list) @@ -116,7 +252,7 @@ module subroutine symba_util_fill_pl(self, inserts, lfill_list) call util_fill(keeps%kin, inserts%kin, lfill_list) call util_fill(keeps%info, inserts%info, lfill_list) - call util_fill_pl(keeps, inserts, lfill_list) + call util_fill_pl(keeps, inserts, lfill_list) ! Note: helio_pl does not have its own fill method, so we skip back to the base class class default write(*,*) 'Error! fill method called for incompatible return type on symba_pl' end select @@ -145,7 +281,7 @@ module subroutine symba_util_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_fill_tp(keeps, inserts, lfill_list) + call util_fill_tp(keeps, inserts, lfill_list) ! Note: helio_tp does not have its own fill method, so we skip back to the base class class default write(*,*) 'Error! fill method called for incompatible return type on symba_tp' end select diff --git a/src/util/util_append.f90 b/src/util/util_append.f90 index 4d9948641..0ca112eb9 100644 --- a/src/util/util_append.f90 +++ b/src/util/util_append.f90 @@ -8,9 +8,9 @@ module subroutine util_append_arr_char_string(arr, source, lsource_mask) !! Append a single array of character string type onto another. If the destination array is not allocated, or is not big enough, this will allocate space for it. implicit none ! Arguments - character(len=STRMAX), dimension(:), allocatable, intent(inout) :: arr !! Destination array - character(len=STRMAX), dimension(:), allocatable, intent(inout) :: source !! Array to append - logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + character(len=STRMAX), dimension(:), allocatable, intent(inout) :: arr !! Destination array + character(len=STRMAX), dimension(:), allocatable, intent(in) :: source !! Array to append + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to ! Internals integer(I4B) :: narr, nsrc @@ -29,9 +29,11 @@ module subroutine util_append_arr_char_string(arr, source, lsource_mask) narr = 0 end if - call util_resize(arr, narr+nsrc) - - arr(narr+1:nsrc) = source(:) + if (present(lsource_mask)) then + arr(narr+1:nsrc) = pack(source(:), lsource_mask(:)) + else + arr(narr+1:nsrc) = source(:) + end if return end subroutine util_append_arr_char_string @@ -43,9 +45,9 @@ module subroutine util_append_arr_DP(arr, source, lsource_mask) !! Append a single array of double precision type onto another. If the destination array is not allocated, or is not big enough, this will allocate space for it. implicit none ! Arguments - real(DP), dimension(:), allocatable, intent(inout) :: arr !! Destination array - real(DP), dimension(:), allocatable, intent(inout) :: source !! Array to append - logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + real(DP), dimension(:), allocatable, intent(inout) :: arr !! Destination array + real(DP), dimension(:), allocatable, intent(in) :: source !! Array to append + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to ! Internals integer(I4B) :: narr, nsrc @@ -64,9 +66,11 @@ module subroutine util_append_arr_DP(arr, source, lsource_mask) narr = 0 end if - call util_resize(arr, narr+nsrc) - - arr(narr+1:nsrc) = source(:) + if (present(lsource_mask)) then + arr(narr+1:nsrc) = pack(source(:), lsource_mask(:)) + else + arr(narr+1:nsrc) = source(:) + end if return end subroutine util_append_arr_DP @@ -78,9 +82,9 @@ module subroutine util_append_arr_DPvec(arr, source, lsource_mask) !! Append a single array of double precision vector type of size (NDIM, n) onto another. If the destination array is not allocated, or is not big enough, this will allocate space for it. implicit none ! Arguments - real(DP), dimension(:,:), allocatable, intent(inout) :: arr !! Destination array - real(DP), dimension(:,:), allocatable, intent(inout) :: source !! Array to append - logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + real(DP), dimension(:,:), allocatable, intent(inout) :: arr !! Destination array + real(DP), dimension(:,:), allocatable, intent(in) :: source !! Array to append + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to ! Internals integer(I4B) :: narr, nsrc @@ -95,13 +99,17 @@ module subroutine util_append_arr_DPvec(arr, source, lsource_mask) if (allocated(arr)) then narr = size(arr, dim=2) else - allocate(arr(NDIM,nsrc)) + allocate(arr(NDIM, nsrc)) narr = 0 end if - call util_resize(arr, narr+nsrc) - - arr(:,narr+1:nsrc) = source(:,:) + if (present(lsource_mask)) then + arr(1, narr+1:nsrc) = pack(source(1,:), lsource_mask(:)) + arr(2, narr+1:nsrc) = pack(source(2,:), lsource_mask(:)) + arr(3, narr+1:nsrc) = pack(source(3,:), lsource_mask(:)) + else + arr(:, narr+1:nsrc) = source(:,:) + end if return end subroutine util_append_arr_DPvec @@ -113,9 +121,9 @@ module subroutine util_append_arr_I4B(arr, source, lsource_mask) !! Append a single array of integer(I4B) onto another. If the destination array is not allocated, or is not big enough, this will allocate space for it. implicit none ! Arguments - integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), allocatable, intent(inout) :: source !! Array to append - logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Destination array + integer(I4B), dimension(:), allocatable, intent(in) :: source !! Array to append + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to ! Internals integer(I4B) :: narr, nsrc @@ -134,9 +142,12 @@ module subroutine util_append_arr_I4B(arr, source, lsource_mask) narr = 0 end if - call util_resize(arr, narr+nsrc) + if (present(lsource_mask)) then + arr(narr+1:nsrc) = pack(source(:), lsource_mask(:)) + else + arr(narr+1:nsrc) = source(:) + end if - arr(narr+1:nsrc) = source(:) return end subroutine util_append_arr_I4B @@ -148,20 +159,14 @@ module subroutine util_append_arr_logical(arr, source, lsource_mask) !! Append a single array of logical type onto another. If the destination array is not allocated, or is not big enough, this will allocate space for it. implicit none ! Arguments - logical, dimension(:), allocatable, intent(inout) :: arr !! Destination array - logical, dimension(:), allocatable, intent(inout) :: source !! Array to append - logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + logical, dimension(:), allocatable, intent(inout) :: arr !! Destination array + logical, dimension(:), allocatable, intent(in) :: source !! Array to append + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to ! Internals integer(I4B) :: narr, nsrc if (.not. allocated(source)) return - if (present(lsource_mask)) then - nsrc = count(lsource_mask) - else - nsrc = size(source) - end if - if (allocated(arr)) then narr = size(arr) else @@ -169,9 +174,17 @@ module subroutine util_append_arr_logical(arr, source, lsource_mask) narr = 0 end if - call util_resize(arr, narr+nsrc) + if (present(lsource_mask)) then + nsrc = count(lsource_mask) + else + nsrc = size(source) + end if - arr(narr+1:nsrc) = source(:) + if (present(lsource_mask)) then + arr(narr+1:nsrc) = pack(source(:), lsource_mask(:)) + else + arr(narr+1:nsrc) = source(:) + end if return end subroutine util_append_arr_logical @@ -184,14 +197,101 @@ module subroutine util_append_body(self, source, lsource_mask) !! This method will automatically resize the destination body if it is too small implicit none ! Arguments - class(swiftest_body), intent(inout) :: self !! Swiftest body object - class(swiftest_body), intent(in) :: source !! Source object to append - logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to - - associate(nold => self%nbody, nnew => source%nbody) + class(swiftest_body), intent(inout) :: self !! Swiftest body object + class(swiftest_body), intent(in) :: source !! Source object to append + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + + call util_append(self%name, source%name, lsource_mask) + call util_append(self%status, source%status, lsource_mask) + call util_append(self%ldiscard, source%ldiscard, lsource_mask) + call util_append(self%lmask, source%lmask, lsource_mask) + call util_append(self%mu, source%mu, lsource_mask) + call util_append(self%xh, source%xh, lsource_mask) + call util_append(self%vh, source%vh, lsource_mask) + call util_append(self%xb, source%xb, lsource_mask) + call util_append(self%vb, source%vb, lsource_mask) + call util_append(self%ah, source%ah, lsource_mask) + call util_append(self%aobl, source%aobl, lsource_mask) + call util_append(self%atide, source%atide, lsource_mask) + call util_append(self%agr, source%agr, lsource_mask) + call util_append(self%ir3h, source%ir3h, lsource_mask) + call util_append(self%a, source%a, lsource_mask) + call util_append(self%e, source%e, lsource_mask) + call util_append(self%inc, source%inc, lsource_mask) + call util_append(self%capom, source%capom, lsource_mask) + call util_append(self%omega, source%omega, lsource_mask) + call util_append(self%capm, source%capm, lsource_mask) + + self%nbody = count(self%status(:) == ACTIVE) - end associate return end subroutine util_append_body + + module subroutine util_append_pl(self, source, lsource_mask) + !! author: David A. Minton + !! + !! Append components from one Swiftest body object to another. + !! This method will automatically resize the destination body if it is too small + implicit none + ! Arguments + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_body), intent(in) :: source !! Source object to append + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + + + select type(source) + class is (swiftest_pl) + call util_append(self%mass, source%mass, lsource_mask) + call util_append(self%Gmass, source%Gmass, lsource_mask) + call util_append(self%rhill, source%rhill, lsource_mask) + call util_append(self%radius, source%radius, lsource_mask) + call util_append(self%xbeg, source%xbeg, lsource_mask) + call util_append(self%xend, source%xend, lsource_mask) + call util_append(self%vbeg, source%vbeg, lsource_mask) + call util_append(self%density, source%density, lsource_mask) + call util_append(self%Ip, source%Ip, lsource_mask) + call util_append(self%rot, source%rot, lsource_mask) + call util_append(self%k2, source%k2, lsource_mask) + call util_append(self%Q, source%Q, lsource_mask) + call util_append(self%tlag, source%tlag, lsource_mask) + + call util_append_body(self, source, lsource_mask) + + call self%eucl_index() + class default + write(*,*) "Invalid object passed to the append method. Source must be of class swiftest_pl or its descendents" + call util_exit(FAILURE) + end select + + return + end subroutine util_append_pl + + + module subroutine util_append_tp(self, source, lsource_mask) + !! author: David A. Minton + !! + !! Append components from one Swiftest body object to another. + !! This method will automatically resize the destination body if it is too small + implicit none + ! Arguments + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + class(swiftest_body), intent(in) :: source !! Source object to append + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + + select type(source) + class is (swiftest_tp) + call util_append(self%isperi, source%isperi, lsource_mask) + call util_append(self%peri, source%peri, lsource_mask) + call util_append(self%atp, source%atp, lsource_mask) + + call util_append_body(self, source, lsource_mask) + class default + write(*,*) "Invalid object passed to the append method. Source must be of class swiftest_tp or its descendents" + call util_exit(FAILURE) + end select + + return + end subroutine util_append_tp + end submodule s_util_append \ No newline at end of file diff --git a/src/util/util_exit.f90 b/src/util/util_exit.f90 index 6814b0029..e770c10f5 100644 --- a/src/util/util_exit.f90 +++ b/src/util/util_exit.f90 @@ -26,6 +26,7 @@ module subroutine util_exit(code) case default write(*, FAIL_MSG) VERSION_NUMBER write(*, BAR) + error stop end select stop diff --git a/src/whm/whm_util.f90 b/src/whm/whm_util.f90 index c0f3a021b..5a095192c 100644 --- a/src/whm/whm_util.f90 +++ b/src/whm/whm_util.f90 @@ -2,38 +2,33 @@ use swiftest contains - module subroutine whm_util_spill_pl(self, discards, lspill_list, ldestructive) + module subroutine whm_util_append_pl(self, source, lsource_mask) !! author: David A. Minton !! - !! Move spilled (discarded) WHM test particle structure from active list to discard list - !! - !! Adapted from David E. Kaufmann's Swifter routine whm_discard_spill.f90 + !! Append components from one massive body object to another. + !! This method will automatically resize the destination body if it is too small implicit none - ! Arguments - 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) - 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 + !! Arguments + class(whm_pl), intent(inout) :: self !! WHM massive body object + class(swiftest_body), intent(in) :: source !! Source object to append + logical, dimension(:), optional, intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + + select type(source) + class is (whm_pl) + call util_append(self%eta, source%eta, lsource_mask) + call util_append(self%muj, source%muj, lsource_mask) + call util_append(self%ir3j, source%ir3j, lsource_mask) + call util_append(self%xj, source%xj, lsource_mask) + call util_append(self%vj, source%vj, lsource_mask) + + call util_append_pl(self, source, lsource_mask) + class default + write(*,*) "Invalid object passed to the append method. Source must be of class whm_pl or its descendents" + call util_exit(FAILURE) + end select return - end subroutine whm_util_spill_pl - + end subroutine whm_util_append_pl module subroutine whm_util_fill_pl(self, inserts, lfill_list) !! author: David A. Minton @@ -61,7 +56,8 @@ module subroutine whm_util_fill_pl(self, 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' + write(*,*) "Invalid object passed to the fill method. Inserts must be of class whm_pl or its descendents" + call util_exit(FAILURE) end select end associate @@ -186,5 +182,38 @@ module subroutine whm_util_sort_rearrange_pl(self, ind) return end subroutine whm_util_sort_rearrange_pl + + + 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 + !! + !! Adapted from David E. Kaufmann's Swifter routine whm_discard_spill.f90 + implicit none + ! Arguments + 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) + 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_spill_pl end submodule s_whm_util