From d48cc7851ff9bb543a2309244d182a5320621d6e Mon Sep 17 00:00:00 2001 From: David Minton Date: Sat, 31 Jul 2021 19:44:06 -0400 Subject: [PATCH] Added spill methods to SyMBA --- src/modules/symba_classes.f90 | 18 +++++++ src/symba/symba_util.f90 | 95 +++++++++++++++++++++++++++++++++++ src/util/util_copy.f90 | 1 - 3 files changed, 113 insertions(+), 1 deletion(-) diff --git a/src/modules/symba_classes.f90 b/src/modules/symba_classes.f90 index 6a878520a..0080b1e07 100644 --- a/src/modules/symba_classes.f90 +++ b/src/modules/symba_classes.f90 @@ -95,6 +95,7 @@ module symba_classes procedure :: fill => symba_util_copy_fill_pl !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) procedure :: sort => symba_util_sort_pl !! Sorts body arrays by a sortable componen procedure :: rearrange => symba_util_sort_rearrange_pl !! Rearranges the order of array elements of body based on an input index array. Used in sorting methods + procedure :: spill => symba_util_copy_spill_pl !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) end type symba_pl !******************************************************************************************************************************** @@ -113,6 +114,7 @@ module symba_classes procedure :: fill => symba_util_copy_fill_tp !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) procedure :: sort => symba_util_sort_tp !! Sorts body arrays by a sortable componen procedure :: rearrange => symba_util_sort_rearrange_tp !! Rearranges the order of array elements of body based on an input index array. Used in sorting methods + procedure :: spill => symba_util_copy_spill_tp !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) end type symba_tp !******************************************************************************************************************************** @@ -450,6 +452,22 @@ module subroutine symba_util_resize_pltpenc(self, nrequested) integer(I4B), intent(in) :: nrequested !! New size of list needed end subroutine symba_util_resize_pltpenc + module subroutine symba_util_copy_spill_pl(self, discards, lspill_list) + use swiftest_classes, only : swiftest_body + implicit none + class(symba_pl), intent(inout) :: self !! SyMBA massive body object + class(swiftest_body), intent(inout) :: discards !! Discarded object + logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards + end subroutine symba_util_copy_spill_pl + + module subroutine symba_util_copy_spill_tp(self, discards, lspill_list) + use swiftest_classes, only : swiftest_body + implicit none + class(symba_tp), intent(inout) :: self !! SyMBA test particle object + class(swiftest_body), intent(inout) :: discards !! Discarded object + logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards + end subroutine symba_util_copy_spill_tp + module subroutine symba_util_sort_pl(self, sortby, ascending) implicit none class(symba_pl), intent(inout) :: self !! SyMBA massive body object diff --git a/src/symba/symba_util.f90 b/src/symba/symba_util.f90 index b8dbbd49a..7d65665f8 100644 --- a/src/symba/symba_util.f90 +++ b/src/symba/symba_util.f90 @@ -140,6 +140,7 @@ module subroutine symba_util_copy_plplenc(self, source) return end subroutine symba_util_copy_plplenc + module subroutine symba_util_resize_pltpenc(self, nrequested) !! author: David A. Minton !! @@ -332,4 +333,98 @@ module subroutine symba_util_sort_rearrange_tp(self, ind) return end subroutine symba_util_sort_rearrange_tp + + module subroutine symba_util_copy_spill_pl(self, discards, lspill_list) + !! author: David A. Minton + !! + !! Move spilled (discarded) SyMBA massive body particle structure from active list to discard list + !! Adapted from David E. Kaufmann's Swifter routine whm_discard_spill.f90 + implicit none + ! Arguments + class(symba_pl), intent(inout) :: self !! SyMBA massive body object + class(swiftest_body), intent(inout) :: discards !! Discarded object + logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards + ! 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) + select type(discards) + class is (symba_pl) + discards%lcollision(:) = pack(keeps%lcollision(:), lspill_list(:)) + discards%lencounter(:) = pack(keeps%lencounter(:), lspill_list(:)) + discards%lmtiny(:) = pack(keeps%lmtiny(:), lspill_list(:)) + discards%nplenc(:) = pack(keeps%nplenc(:), lspill_list(:)) + discards%ntpenc(:) = pack(keeps%ntpenc(:), lspill_list(:)) + discards%levelg(:) = pack(keeps%levelg(:), lspill_list(:)) + discards%levelm(:) = pack(keeps%levelm(:), lspill_list(:)) + discards%isperi(:) = pack(keeps%isperi(:), lspill_list(:)) + discards%peri(:) = pack(keeps%peri(:), lspill_list(:)) + discards%atp(:) = pack(keeps%atp(:), lspill_list(:)) + discards%info(:) = pack(keeps%info(:), lspill_list(:)) + discards%kin(:) = pack(keeps%kin(:), lspill_list(:)) + + if (count(.not.lspill_list(:)) > 0) then + keeps%lcollision(:) = pack(keeps%lcollision(:), .not. lspill_list(:)) + keeps%lencounter(:) = pack(keeps%lencounter(:), .not. lspill_list(:)) + keeps%lmtiny(:) = pack(keeps%lmtiny(:), .not. lspill_list(:)) + keeps%nplenc(:) = pack(keeps%nplenc(:), .not. lspill_list(:)) + keeps%ntpenc(:) = pack(keeps%ntpenc(:), .not. lspill_list(:)) + keeps%levelg(:) = pack(keeps%levelg(:), .not. lspill_list(:)) + keeps%levelm(:) = pack(keeps%levelm(:), .not. lspill_list(:)) + keeps%isperi(:) = pack(keeps%isperi(:), .not. lspill_list(:)) + keeps%peri(:) = pack(keeps%peri(:), .not. lspill_list(:)) + keeps%atp(:) = pack(keeps%atp(:), .not. lspill_list(:)) + keeps%info(:) = pack(keeps%info(:), .not. lspill_list(:)) + keeps%kin(:) = pack(keeps%kin(:), .not. lspill_list(:)) + end if + + call util_copy_spill_pl(keeps, discards, lspill_list) + class default + write(*,*) 'Error! spill method called for incompatible return type on symba_pl' + end select + end associate + + return + end subroutine symba_util_copy_spill_pl + + + module subroutine symba_util_copy_spill_tp(self, discards, lspill_list) + !! author: David A. Minton + !! + !! Move spilled (discarded) SyMBA test particle structure from active list to discard list + !! Adapted from David E. Kaufmann's Swifter routine whm_discard_spill.f90 + implicit none + ! Arguments + class(symba_tp), intent(inout) :: self !! SyMBA test particle object + class(swiftest_body), intent(inout) :: discards !! Discarded object + logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards + ! 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) + select type(discards) + class is (symba_pl) + discards%nplenc(:) = pack(keeps%nplenc(:), lspill_list(:)) + discards%levelg(:) = pack(keeps%levelg(:), lspill_list(:)) + discards%levelm(:) = pack(keeps%levelm(:), lspill_list(:)) + + if (count(.not.lspill_list(:)) > 0) then + keeps%nplenc(:) = pack(keeps%nplenc(:), .not. lspill_list(:)) + keeps%levelg(:) = pack(keeps%levelg(:), .not. lspill_list(:)) + keeps%levelm(:) = pack(keeps%levelm(:), .not. lspill_list(:)) + end if + + call util_copy_spill_tp(keeps, discards, lspill_list) + class default + write(*,*) 'Error! spill method called for incompatible return type on symba_pl' + end select + end associate + + return + end subroutine symba_util_copy_spill_tp + end submodule s_symba_util \ No newline at end of file diff --git a/src/util/util_copy.f90 b/src/util/util_copy.f90 index 3a4b1e9f6..261a490fd 100644 --- a/src/util/util_copy.f90 +++ b/src/util/util_copy.f90 @@ -378,7 +378,6 @@ module subroutine util_copy_spill_body(self, discards, lspill_list) allocate(discards%ldiscard(discards%nbody)) keeps%ldiscard = .false. discards%ldiscard = .true. - end associate return