diff --git a/src/modules/symba_classes.f90 b/src/modules/symba_classes.f90 index f0cf9e00d..eb6a74482 100644 --- a/src/modules/symba_classes.f90 +++ b/src/modules/symba_classes.f90 @@ -418,6 +418,36 @@ module subroutine symba_step_reset_system(self) class(symba_nbody_system), intent(inout) :: self !! SyMBA nbody system object end subroutine symba_step_reset_system + module subroutine symba_util_copy_pltpenc(self, source) + implicit none + class(symba_pltpenc), intent(inout) :: self !! SyMBA pl-tp encounter list + class(symba_pltpenc), intent(in) :: source !! Source object to copy into + end subroutine symba_util_copy_pltpenc + + module subroutine symba_util_copy_plplenc(self, source) + implicit none + class(symba_plplenc), intent(inout) :: self !! SyMBA pl-pl encounter list + class(symba_pltpenc), intent(in) :: source !! Source object to copy into + end subroutine symba_util_copy_plplenc + end interface + + interface util_fill + module subroutine symba_util_fill_arr_char_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 + + module subroutine symba_util_fill_arr_char_kin(keeps, inserts, lfill_list) + implicit none + type(symba_kinship), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + type(symba_kinship), dimension(:), allocatable, intent(in) :: inserts !! Array of values to insert into keep + logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps + end subroutine symba_util_fill_arr_char_kin + end interface + + interface module subroutine symba_util_fill_pl(self, inserts, lfill_list) use swiftest_classes, only : swiftest_body implicit none @@ -434,42 +464,12 @@ module subroutine symba_util_fill_tp(self, inserts, lfill_list) logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps end subroutine symba_util_fill_tp - module subroutine symba_util_copy_pltpenc(self, source) - implicit none - class(symba_pltpenc), intent(inout) :: self !! SyMBA pl-tp encounter list - class(symba_pltpenc), intent(in) :: source !! Source object to copy into - end subroutine symba_util_copy_pltpenc - - module subroutine symba_util_copy_plplenc(self, source) - implicit none - class(symba_plplenc), intent(inout) :: self !! SyMBA pl-pl encounter list - class(symba_pltpenc), intent(in) :: source !! Source object to copy into - end subroutine symba_util_copy_plplenc - module subroutine symba_util_resize_pltpenc(self, nrequested) implicit none class(symba_pltpenc), intent(inout) :: self !! SyMBA pl-tp encounter list integer(I4B), intent(in) :: nrequested !! New size of list needed end subroutine symba_util_resize_pltpenc - module subroutine symba_util_spill_pl(self, discards, lspill_list, ldestructive) - use swiftest_classes, only : swiftest_body - implicit none - class(symba_pl), intent(inout) :: self !! SyMBA massive body object - class(swiftest_body), intent(inout) :: discards !! Discarded object - logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards - logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not - end subroutine symba_util_spill_pl - - module subroutine symba_util_spill_tp(self, discards, lspill_list, ldestructive) - use swiftest_classes, only : swiftest_body - implicit none - class(symba_tp), intent(inout) :: self !! SyMBA test particle object - class(swiftest_body), intent(inout) :: discards !! Discarded object - logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards - logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not - end subroutine symba_util_spill_tp - module subroutine symba_util_sort_pl(self, sortby, ascending) implicit none class(symba_pl), intent(inout) :: self !! SyMBA massive body object @@ -495,7 +495,44 @@ module subroutine symba_util_sort_rearrange_tp(self, ind) class(symba_tp), intent(inout) :: self !! SyMBA massive body object integer(I4B), dimension(:), intent(in) :: ind !! Index array used to restructure the body (should contain all 1:n index values in the desired order) end subroutine symba_util_sort_rearrange_tp + end interface + + interface util_spill + module subroutine symba_util_spill_arr_info(keeps, discards, lspill_list, ldestructive) + implicit none + type(symba_particle_info), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + type(symba_particle_info), dimension(:), allocatable, intent(inout) :: discards !! Array of discards + logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discardss + logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not + end subroutine symba_util_spill_arr_info + + module subroutine symba_util_spill_arr_kin(keeps, discards, lspill_list, ldestructive) + implicit none + type(symba_kinship), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + type(symba_kinship), dimension(:), allocatable, intent(inout) :: discards !! Array of discards + logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discardss + logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not + end subroutine symba_util_spill_arr_kin + end interface + interface + module subroutine symba_util_spill_pl(self, discards, lspill_list, ldestructive) + use swiftest_classes, only : swiftest_body + implicit none + class(symba_pl), intent(inout) :: self !! SyMBA massive body object + class(swiftest_body), intent(inout) :: discards !! Discarded object + logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards + logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not + end subroutine symba_util_spill_pl + + module subroutine symba_util_spill_tp(self, discards, lspill_list, ldestructive) + use swiftest_classes, only : swiftest_body + implicit none + class(symba_tp), intent(inout) :: self !! SyMBA test particle object + class(swiftest_body), intent(inout) :: discards !! Discarded object + logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discards + logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not + end subroutine symba_util_spill_tp end interface end module symba_classes \ No newline at end of file diff --git a/src/symba/symba_util.f90 b/src/symba/symba_util.f90 index 8c9a0a1d7..d1d7fc59e 100644 --- a/src/symba/symba_util.f90 +++ b/src/symba/symba_util.f90 @@ -2,6 +2,92 @@ use swiftest contains + module subroutine symba_util_copy_pltpenc(self, source) + !! author: David A. Minton + !! + !! Copies elements from the source encounter list into self. + implicit none + ! Arguments + class(symba_pltpenc), intent(inout) :: self !! SyMBA pl-tp encounter list + class(symba_pltpenc), intent(in) :: source !! Source object to copy into + + associate(n => source%nenc) + self%nenc = n + self%lvdotr(1:n) = source%lvdotr(1:n) + self%status(1:n) = source%status(1:n) + self%level(1:n) = source%level(1:n) + self%index1(1:n) = source%index1(1:n) + self%index2(1:n) = source%index2(1:n) + end associate + + return + end subroutine symba_util_copy_pltpenc + + + module subroutine symba_util_copy_plplenc(self, source) + !! author: David A. Minton + !! + !! Copies elements from the source encounter list into self. + implicit none + ! Arguments + class(symba_plplenc), intent(inout) :: self !! SyMBA pl-pl encounter list + class(symba_pltpenc), intent(in) :: source !! Source object to copy into + + call symba_util_copy_pltpenc(self, source) + associate(n => source%nenc) + select type(source) + class is (symba_plplenc) + self%xh1(:,1:n) = source%xh1(:,1:n) + self%xh2(:,1:n) = source%xh2(:,1:n) + self%vb1(:,1:n) = source%vb1(:,1:n) + self%vb2(:,1:n) = source%vb2(:,1:n) + end select + end associate + + return + end subroutine symba_util_copy_plplenc + + + module subroutine symba_util_fill_arr_char_info(keeps, inserts, lfill_list) + !! author: David A. Minton + !! + !! Performs a fill operation on a single array of particle origin information types + !! This is the inverse of a spill operation + implicit none + ! Arguments + 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 + + if (.not.allocated(keeps) .or. .not.allocated(inserts)) return + + keeps(:) = unpack(keeps(:), .not.lfill_list(:), keeps(:)) + keeps(:) = unpack(inserts(:), lfill_list(:), keeps(:)) + + return + end subroutine symba_util_fill_arr_char_info + + + module subroutine symba_util_fill_arr_char_kin(keeps, inserts, lfill_list) + !! author: David A. Minton + !! + !! Performs a fill operation on a single array of particle kinship types + !! This is the inverse of a spill operation + implicit none + ! Arguments + type(symba_kinship), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + type(symba_kinship), dimension(:), allocatable, intent(in) :: inserts !! Array of values to insert into keep + logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps + + if (.not.allocated(keeps) .or. .not.allocated(inserts)) return + + keeps(:) = unpack(keeps(:), .not.lfill_list(:), keeps(:)) + keeps(:) = unpack(inserts(:), lfill_list(:), keeps(:)) + + return + end subroutine symba_util_fill_arr_char_kin + + module subroutine symba_util_fill_pl(self, inserts, lfill_list) !! author: David A. Minton !! @@ -27,12 +113,8 @@ module subroutine symba_util_fill_pl(self, inserts, lfill_list) call util_fill(keeps%isperi, inserts%isperi, lfill_list) call util_fill(keeps%peri, inserts%peri, lfill_list) call util_fill(keeps%atp, inserts%atp, lfill_list) - - keeps%kin(:) = unpack(keeps%kin(:), .not.lfill_list(:), keeps%kin(:)) - keeps%kin(:) = unpack(inserts%kin(:), lfill_list(:), keeps%kin(:)) - - keeps%info(:) = unpack(keeps%info(:), .not.lfill_list(:), keeps%info(:)) - keeps%info(:) = unpack(inserts%info(:), lfill_list(:), keeps%info(:)) + 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) class default @@ -43,6 +125,7 @@ module subroutine symba_util_fill_pl(self, inserts, lfill_list) return end subroutine symba_util_fill_pl + module subroutine symba_util_fill_tp(self, inserts, lfill_list) !! author: David A. Minton !! @@ -71,51 +154,6 @@ module subroutine symba_util_fill_tp(self, inserts, lfill_list) return end subroutine symba_util_fill_tp - module subroutine symba_util_copy_pltpenc(self, source) - !! author: David A. Minton - !! - !! Copies elements from the source encounter list into self. - implicit none - ! Arguments - class(symba_pltpenc), intent(inout) :: self !! SyMBA pl-tp encounter list - class(symba_pltpenc), intent(in) :: source !! Source object to copy into - - associate(n => source%nenc) - self%nenc = n - self%lvdotr(1:n) = source%lvdotr(1:n) - self%status(1:n) = source%status(1:n) - self%level(1:n) = source%level(1:n) - self%index1(1:n) = source%index1(1:n) - self%index2(1:n) = source%index2(1:n) - end associate - - return - end subroutine symba_util_copy_pltpenc - - - module subroutine symba_util_copy_plplenc(self, source) - !! author: David A. Minton - !! - !! Copies elements from the source encounter list into self. - implicit none - ! Arguments - class(symba_plplenc), intent(inout) :: self !! SyMBA pl-pl encounter list - class(symba_pltpenc), intent(in) :: source !! Source object to copy into - - call symba_util_copy_pltpenc(self, source) - associate(n => source%nenc) - select type(source) - class is (symba_plplenc) - self%xh1(:,1:n) = source%xh1(:,1:n) - self%xh2(:,1:n) = source%xh2(:,1:n) - self%vb1(:,1:n) = source%vb1(:,1:n) - self%vb2(:,1:n) = source%vb2(:,1:n) - end select - end associate - - return - end subroutine symba_util_copy_plplenc - module subroutine symba_util_resize_pltpenc(self, nrequested) !! author: David A. Minton @@ -310,6 +348,62 @@ module subroutine symba_util_sort_rearrange_tp(self, ind) end subroutine symba_util_sort_rearrange_tp + module subroutine symba_util_spill_arr_info(keeps, discards, lspill_list, ldestructive) + !! author: David A. Minton + !! + !! Performs a spill operation on a single array of particle origin information types + !! This is the inverse of a spill operation + implicit none + ! Arguments + type(symba_particle_info), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + type(symba_particle_info), dimension(:), allocatable, intent(inout) :: discards !! Array of discards + logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discardss + logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not + + if (.not.allocated(keeps) .or. count(lspill_list(:)) == 0) return + if (.not.allocated(discards)) allocate(discards(count(lspill_list(:)))) + + discards(:) = pack(keeps(:), lspill_list(:)) + if (ldestructive) then + if (count(.not.lspill_list(:)) > 0) then + keeps(:) = pack(keeps(:), .not. lspill_list(:)) + else + deallocate(keeps) + end if + end if + + return + end subroutine symba_util_spill_arr_info + + + module subroutine symba_util_spill_arr_kin(keeps, discards, lspill_list, ldestructive) + !! author: David A. Minton + !! + !! Performs a spill operation on a single array of particle kinships + !! This is the inverse of a spill operation + implicit none + ! Arguments + type(symba_kinship), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + type(symba_kinship), dimension(:), allocatable, intent(inout) :: discards !! Array of discards + logical, dimension(:), intent(in) :: lspill_list !! Logical array of bodies to spill into the discardss + logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter the keeps array or not + + if (.not.allocated(keeps) .or. count(lspill_list(:)) == 0) return + if (.not.allocated(discards)) allocate(discards(count(lspill_list(:)))) + + discards(:) = pack(keeps(:), lspill_list(:)) + if (ldestructive) then + if (count(.not.lspill_list(:)) > 0) then + keeps(:) = pack(keeps(:), .not. lspill_list(:)) + else + deallocate(keeps) + end if + end if + + return + end subroutine symba_util_spill_arr_kin + + module subroutine symba_util_spill_pl(self, discards, lspill_list, ldestructive) !! author: David A. Minton !! @@ -329,7 +423,6 @@ module subroutine symba_util_spill_pl(self, discards, lspill_list, ldestructive) associate(keeps => self) select type(discards) class is (symba_pl) - call util_spill(keeps%lcollision, discards%lcollision, lspill_list, ldestructive) call util_spill(keeps%lencounter, discards%lencounter, lspill_list, ldestructive) call util_spill(keeps%lmtiny, discards%lmtiny, lspill_list, ldestructive) @@ -340,15 +433,8 @@ module subroutine symba_util_spill_pl(self, discards, lspill_list, ldestructive) call util_spill(keeps%isperi, discards%isperi, lspill_list, ldestructive) call util_spill(keeps%peri, discards%peri, lspill_list, ldestructive) call util_spill(keeps%atp, discards%atp, lspill_list, ldestructive) - discards%info(:) = pack(keeps%info(:), lspill_list(:)) - discards%kin(:) = pack(keeps%kin(:), lspill_list(:)) - - if (ldestructive) then - if (count(.not.lspill_list(:)) > 0) then - keeps%info(:) = pack(keeps%info(:), .not. lspill_list(:)) - keeps%kin(:) = pack(keeps%kin(:), .not. lspill_list(:)) - end if - end if + call util_spill(keeps%info, discards%info, lspill_list, ldestructive) + call util_spill(keeps%kin, discards%kin, lspill_list, ldestructive) call util_spill_pl(keeps, discards, lspill_list, ldestructive) class default