From 741971e5034cfdf68ea2f6bba91d23f7aae6e4d4 Mon Sep 17 00:00:00 2001 From: David A Minton Date: Mon, 9 Aug 2021 23:06:40 -0400 Subject: [PATCH] Improved handling of appends --- src/modules/swiftest_classes.f90 | 17 ++- src/modules/symba_classes.f90 | 6 +- src/rmvs/rmvs_util.f90 | 30 ++--- src/symba/symba_fragmentation.f90 | 3 + src/symba/symba_util.f90 | 104 ++++++++--------- src/util/util_append.f90 | 180 +++++++++++++----------------- src/whm/whm_util.f90 | 16 +-- 7 files changed, 171 insertions(+), 185 deletions(-) diff --git a/src/modules/swiftest_classes.f90 b/src/modules/swiftest_classes.f90 index 0d7fac843..25f258d0c 100644 --- a/src/modules/swiftest_classes.f90 +++ b/src/modules/swiftest_classes.f90 @@ -832,38 +832,43 @@ end subroutine user_kick_getacch_body end interface interface util_append - module subroutine util_append_arr_char_string(arr, source, lsource_mask) + module subroutine util_append_arr_char_string(arr, source, nold, nsrc, lsource_mask) implicit none character(len=STRMAX), dimension(:), allocatable, intent(inout) :: arr !! Destination array character(len=STRMAX), dimension(:), allocatable, intent(in) :: source !! Array to append + integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively logical, dimension(:), 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) + module subroutine util_append_arr_DP(arr, source, nold, nsrc, lsource_mask) implicit none real(DP), dimension(:), allocatable, intent(inout) :: arr !! Destination array real(DP), dimension(:), allocatable, intent(in) :: source !! Array to append + integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively logical, dimension(:), 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) + module subroutine util_append_arr_DPvec(arr, source, nold, nsrc, lsource_mask) implicit none real(DP), dimension(:,:), allocatable, intent(inout) :: arr !! Destination array real(DP), dimension(:,:), allocatable, intent(in) :: source !! Array to append + integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively logical, dimension(:), 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) + module subroutine util_append_arr_I4B(arr, source, nold, nsrc, lsource_mask) implicit none integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Destination array integer(I4B), dimension(:), allocatable, intent(in) :: source !! Array to append + integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively logical, dimension(:), 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) + module subroutine util_append_arr_logical(arr, source, nold, nsrc, lsource_mask) implicit none logical, dimension(:), allocatable, intent(inout) :: arr !! Destination array logical, dimension(:), allocatable, intent(in) :: source !! Array to append + integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to end subroutine util_append_arr_logical end interface @@ -872,7 +877,7 @@ end subroutine util_append_arr_logical module subroutine util_append_body(self, source, 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_body), intent(in) :: source !! Source object to append logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to end subroutine util_append_body diff --git a/src/modules/symba_classes.f90 b/src/modules/symba_classes.f90 index e8b5918b3..b80a9cab8 100644 --- a/src/modules/symba_classes.f90 +++ b/src/modules/symba_classes.f90 @@ -488,17 +488,19 @@ end subroutine symba_step_reset_system end interface interface util_append - module subroutine symba_util_append_arr_info(arr, source, lsource_mask) + module subroutine symba_util_append_arr_info(arr, source, nold, nsrc, 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 + integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively logical, dimension(:), 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) + module subroutine symba_util_append_arr_kin(arr, source, nold, nsrc, 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 + integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to end subroutine symba_util_append_arr_kin end interface diff --git a/src/rmvs/rmvs_util.f90 b/src/rmvs/rmvs_util.f90 index 67a76acb3..3be6130bf 100644 --- a/src/rmvs/rmvs_util.f90 +++ b/src/rmvs/rmvs_util.f90 @@ -15,17 +15,19 @@ module subroutine rmvs_util_append_pl(self, source, lsource_mask) select type(source) class is (rmvs_pl) - call whm_util_append_pl(self, source, lsource_mask) + associate(nold => self%nbody, nsrc => source%nbody) + call whm_util_append_pl(self, source, lsource_mask) - 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) + call util_append(self%nenc, source%nenc, nold, nsrc, lsource_mask) + call util_append(self%tpenc1P, source%tpenc1P, nold, nsrc, lsource_mask) + call util_append(self%plind, source%plind, nold, nsrc, 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) + ! 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, nold, nsrc, lsource_mask) + !call util_append(self%inner, source%inner, nold, nsrc, lsource_mask) + !call util_append(self%planetocentric, source%planetocentric, nold, nsrc, lsource_mask) + end associate class default write(*,*) "Invalid object passed to the append method. Source must be of class rmvs_pl or its descendents!" call util_exit(FAILURE) @@ -48,11 +50,13 @@ module subroutine rmvs_util_append_tp(self, source, lsource_mask) select type(source) class is (rmvs_tp) - 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 + associate(nold => self%nbody, nsrc => source%nbody) + 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 - 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(self%lperi, source%lperi, nold, nsrc, lsource_mask) + call util_append(self%plperP, source%plperP, nold, nsrc, lsource_mask) + call util_append(self%plencP, source%plencP, nold, nsrc, lsource_mask) + end associate class default write(*,*) "Invalid object passed to the append method. Source must be of class rmvs_tp or its descendents!" call util_exit(FAILURE) diff --git a/src/symba/symba_fragmentation.f90 b/src/symba/symba_fragmentation.f90 index 9b82e145a..f7ce51432 100644 --- a/src/symba/symba_fragmentation.f90 +++ b/src/symba/symba_fragmentation.f90 @@ -140,6 +140,9 @@ module function symba_fragmentation_casedisruption(system, param, family, x, v, nstart = pl_adds%nbody + 1 nend = pl_adds%nbody + plnew%nbody call pl_adds%append(plnew, lsource_mask=[(.true., i=1, plnew%nbody)]) + do i = 1, plnew%nbody + write(*,*) i, pl_adds%xb(:,i) + end do pl_adds%ncomp(nstart:nend) = plnew%nbody call plnew%setup(0, param) diff --git a/src/symba/symba_util.f90 b/src/symba/symba_util.f90 index 37fdca873..9816ab4a2 100644 --- a/src/symba/symba_util.f90 +++ b/src/symba/symba_util.f90 @@ -2,7 +2,7 @@ use swiftest contains - module subroutine symba_util_append_arr_info(arr, source, lsource_mask) + module subroutine symba_util_append_arr_info(arr, source, nold, nsrc, 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. @@ -10,30 +10,24 @@ module subroutine symba_util_append_arr_info(arr, source, lsource_mask) ! Arguments type(symba_particle_info), dimension(:), allocatable, intent(inout) :: arr !! Destination array type(symba_particle_info), dimension(:), allocatable, intent(in) :: source !! Array to append + integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to - ! Internals - integer(I4B) :: narr, nsrc if (.not. allocated(source)) return - nsrc = count(lsource_mask) - - if (allocated(arr)) then - narr = size(arr) + if (.not.allocated(arr)) then + allocate(arr(nold+nsrc)) else - allocate(arr(nsrc)) - narr = 0 + call util_resize(arr, nold + nsrc) end if - call util_resize(arr, narr + nsrc) - - arr(narr + 1:narr + nsrc) = pack(source(:), lsource_mask(:)) + arr(nold + 1:nold + nsrc) = pack(source(1:nsrc), lsource_mask(1:nsrc)) return end subroutine symba_util_append_arr_info - module subroutine symba_util_append_arr_kin(arr, source, lsource_mask) + module subroutine symba_util_append_arr_kin(arr, source, nold, nsrc, 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. @@ -41,24 +35,18 @@ module subroutine symba_util_append_arr_kin(arr, source, lsource_mask) ! Arguments type(symba_kinship), dimension(:), allocatable, intent(inout) :: arr !! Destination array type(symba_kinship), dimension(:), allocatable, intent(in) :: source !! Array to append + integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to - ! Internals - integer(I4B) :: narr, nsrc if (.not. allocated(source)) return - nsrc = count(lsource_mask) - - if (allocated(arr)) then - narr = size(arr) + if (.not.allocated(arr)) then + allocate(arr(nold+nsrc)) else - allocate(arr(nsrc)) - narr = 0 + call util_resize(arr, nold + nsrc) end if - call util_resize(arr, narr + nsrc) - - arr(narr + 1:narr + nsrc) = pack(source(:), lsource_mask(:)) + arr(nold + 1:nold + nsrc) = pack(source(1:nsrc), lsource_mask(1:nsrc)) return end subroutine symba_util_append_arr_kin @@ -77,20 +65,22 @@ module subroutine symba_util_append_pl(self, source, lsource_mask) select type(source) class is (symba_pl) - 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 - - 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) + associate(nold => self%nbody, nsrc => source%nbody) + 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 + + call util_append(self%lcollision, source%lcollision, nold, nsrc, lsource_mask) + call util_append(self%lencounter, source%lencounter, nold, nsrc, lsource_mask) + call util_append(self%lmtiny, source%lmtiny, nold, nsrc, lsource_mask) + call util_append(self%nplenc, source%nplenc, nold, nsrc, lsource_mask) + call util_append(self%ntpenc, source%ntpenc, nold, nsrc, lsource_mask) + call util_append(self%levelg, source%levelg, nold, nsrc, lsource_mask) + call util_append(self%levelm, source%levelm, nold, nsrc, lsource_mask) + call util_append(self%isperi, source%isperi, nold, nsrc, lsource_mask) + call util_append(self%peri, source%peri, nold, nsrc, lsource_mask) + call util_append(self%atp, source%atp, nold, nsrc, lsource_mask) + call util_append(self%kin, source%kin, nold, nsrc, lsource_mask) + call util_append(self%info, source%info, nold, nsrc, lsource_mask) + end associate class default write(*,*) "Invalid object passed to the append method. Source must be of class symba_pl or its descendents!" call util_exit(FAILURE) @@ -113,19 +103,21 @@ module subroutine symba_util_append_merger(self, source, lsource_mask) ! Internals integer(I4B), dimension(:), allocatable :: ncomp_tmp !! Temporary placeholder for ncomp incase we are appending a symba_pl object to a symba_merger - select type(source) - class is (symba_merger) - call symba_util_append_pl(self, source, lsource_mask) - call util_append(self%ncomp, source%ncomp, lsource_mask) - class is (symba_pl) - call symba_util_append_pl(self, source, lsource_mask) - allocate(ncomp_tmp, mold=source%id) - ncomp_tmp(:) = 0 - call util_append(self%ncomp, ncomp_tmp, lsource_mask) - 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 + associate(nold => self%nbody, nsrc => source%nbody) + select type(source) + class is (symba_merger) + call symba_util_append_pl(self, source, lsource_mask) + call util_append(self%ncomp, source%ncomp, nold, nsrc, lsource_mask) + class is (symba_pl) + call symba_util_append_pl(self, source, lsource_mask) + allocate(ncomp_tmp, mold=source%id) + ncomp_tmp(:) = 0 + call util_append(self%ncomp, ncomp_tmp, nold, nsrc, lsource_mask) + 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 + end associate return end subroutine symba_util_append_merger @@ -144,11 +136,13 @@ module subroutine symba_util_append_tp(self, source, lsource_mask) select type(source) class is (symba_tp) - 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 + associate(nold => self%nbody, nsrc => source%nbody) + 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 - 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(self%nplenc, source%nplenc, nold, nsrc, lsource_mask) + call util_append(self%levelg, source%levelg, nold, nsrc, lsource_mask) + call util_append(self%levelm, source%levelm, nold, nsrc, lsource_mask) + end associate class default write(*,*) "Invalid object passed to the append method. Source must be of class symba_tp or its descendents!" call util_exit(FAILURE) diff --git a/src/util/util_append.f90 b/src/util/util_append.f90 index cf0bb4117..221888e4b 100644 --- a/src/util/util_append.f90 +++ b/src/util/util_append.f90 @@ -2,7 +2,7 @@ use swiftest contains - module subroutine util_append_arr_char_string(arr, source, lsource_mask) + module subroutine util_append_arr_char_string(arr, source, nold, nsrc, lsource_mask) !! author: David A. Minton !! !! 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. @@ -10,30 +10,24 @@ module subroutine util_append_arr_char_string(arr, source, lsource_mask) ! Arguments character(len=STRMAX), dimension(:), allocatable, intent(inout) :: arr !! Destination array character(len=STRMAX), dimension(:), allocatable, intent(in) :: source !! Array to append + integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to - ! Internals - integer(I4B) :: narr, nsrc if (.not. allocated(source)) return - nsrc = count(lsource_mask) - - if (allocated(arr)) then - narr = size(arr) + if (.not.allocated(arr)) then + allocate(arr(nold+nsrc)) else - allocate(arr(nsrc)) - narr = 0 + call util_resize(arr, nold + nsrc) end if - call util_resize(arr, narr + nsrc) - - arr(narr + 1:narr + nsrc) = pack(source(:), lsource_mask(:)) + arr(nold + 1:nold + nsrc) = pack(source(1:nsrc), lsource_mask(1:nsrc)) return end subroutine util_append_arr_char_string - module subroutine util_append_arr_DP(arr, source, lsource_mask) + module subroutine util_append_arr_DP(arr, source, nold, nsrc, lsource_mask) !! author: David A. Minton !! !! 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. @@ -41,30 +35,24 @@ module subroutine util_append_arr_DP(arr, source, lsource_mask) ! Arguments real(DP), dimension(:), allocatable, intent(inout) :: arr !! Destination array real(DP), dimension(:), allocatable, intent(in) :: source !! Array to append + integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to - ! Internals - integer(I4B) :: narr, nsrc if (.not. allocated(source)) return - nsrc = count(lsource_mask) - - if (allocated(arr)) then - narr = size(arr) + if (.not.allocated(arr)) then + allocate(arr(nold+nsrc)) else - allocate(arr(nsrc)) - narr = 0 + call util_resize(arr, nold + nsrc) end if - call util_resize(arr, narr + nsrc) - - arr(narr + 1:narr + nsrc) = pack(source(:), lsource_mask(:)) + arr(nold + 1:nold + nsrc) = pack(source(1:nsrc), lsource_mask(1:nsrc)) return end subroutine util_append_arr_DP - module subroutine util_append_arr_DPvec(arr, source, lsource_mask) + module subroutine util_append_arr_DPvec(arr, source, nold, nsrc, lsource_mask) !! author: David A. Minton !! !! 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. @@ -72,32 +60,26 @@ module subroutine util_append_arr_DPvec(arr, source, lsource_mask) ! Arguments real(DP), dimension(:,:), allocatable, intent(inout) :: arr !! Destination array real(DP), dimension(:,:), allocatable, intent(in) :: source !! Array to append + integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to - ! Internals - integer(I4B) :: narr, nsrc if (.not. allocated(source)) return - nsrc = count(lsource_mask) - - if (allocated(arr)) then - narr = size(arr, dim=2) + if (.not.allocated(arr)) then + allocate(arr(NDIM, nold+nsrc)) else - allocate(arr(NDIM, nsrc)) - narr = 0 + call util_resize(arr, nold + nsrc) end if - call util_resize(arr, narr + nsrc) - - arr(1, narr + 1:narr + nsrc) = pack(source(1,:), lsource_mask(:)) - arr(2, narr + 1:narr + nsrc) = pack(source(2,:), lsource_mask(:)) - arr(3, narr + 1:narr + nsrc) = pack(source(3,:), lsource_mask(:)) + arr(1, nold + 1:nold + nsrc) = pack(source(1,1:nsrc), lsource_mask(1:nsrc)) + arr(2, nold + 1:nold + nsrc) = pack(source(2,1:nsrc), lsource_mask(1:nsrc)) + arr(3, nold + 1:nold + nsrc) = pack(source(3,1:nsrc), lsource_mask(1:nsrc)) return end subroutine util_append_arr_DPvec - module subroutine util_append_arr_I4B(arr, source, lsource_mask) + module subroutine util_append_arr_I4B(arr, source, nold, nsrc, lsource_mask) !! author: David A. Minton !! !! 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. @@ -105,30 +87,24 @@ module subroutine util_append_arr_I4B(arr, source, lsource_mask) ! Arguments integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Destination array integer(I4B), dimension(:), allocatable, intent(in) :: source !! Array to append + integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to - ! Internals - integer(I4B) :: narr, nsrc if (.not. allocated(source)) return - nsrc = count(lsource_mask) - - if (allocated(arr)) then - narr = size(arr) + if (.not.allocated(arr)) then + allocate(arr(nold+nsrc)) else - allocate(arr(nsrc)) - narr = 0 + call util_resize(arr, nold + nsrc) end if - call util_resize(arr, narr + nsrc) - - arr(narr + 1:narr + nsrc) = pack(source(:), lsource_mask(:)) + arr(nold + 1:nold + nsrc) = pack(source(1:nsrc), lsource_mask(1:nsrc)) return end subroutine util_append_arr_I4B - module subroutine util_append_arr_logical(arr, source, lsource_mask) + module subroutine util_append_arr_logical(arr, source, nold, nsrc, lsource_mask) !! author: David A. Minton !! !! 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. @@ -136,24 +112,18 @@ module subroutine util_append_arr_logical(arr, source, lsource_mask) ! Arguments logical, dimension(:), allocatable, intent(inout) :: arr !! Destination array logical, dimension(:), allocatable, intent(in) :: source !! Array to append + integer(I4B), intent(in) :: nold, nsrc !! Extend of the old array and the source array, respectively logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to - ! Internals - integer(I4B) :: narr, nsrc if (.not. allocated(source)) return - if (allocated(arr)) then - narr = size(arr) + if (.not.allocated(arr)) then + allocate(arr(nold+nsrc)) else - allocate(arr(nsrc)) - narr = 0 + call util_resize(arr, nold + nsrc) end if - nsrc = count(lsource_mask) - - call util_resize(arr, narr + nsrc) - - arr(narr + 1:narr + nsrc) = pack(source(:), lsource_mask(:)) + arr(nold + 1:nold + nsrc) = pack(source(1:nsrc), lsource_mask(1:nsrc)) return end subroutine util_append_arr_logical @@ -170,27 +140,29 @@ module subroutine util_append_body(self, source, lsource_mask) class(swiftest_body), intent(in) :: source !! Source object to append logical, dimension(:), 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%id, source%id, 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) + associate(nold => self%nbody, nsrc => source%nbody) + call util_append(self%name, source%name, nold, nsrc, lsource_mask) + call util_append(self%id, source%id, nold, nsrc, lsource_mask) + call util_append(self%status, source%status, nold, nsrc, lsource_mask) + call util_append(self%ldiscard, source%ldiscard, nold, nsrc, lsource_mask) + call util_append(self%lmask, source%lmask, nold, nsrc, lsource_mask) + call util_append(self%mu, source%mu, nold, nsrc, lsource_mask) + call util_append(self%xh, source%xh, nold, nsrc, lsource_mask) + call util_append(self%vh, source%vh, nold, nsrc, lsource_mask) + call util_append(self%xb, source%xb, nold, nsrc, lsource_mask) + call util_append(self%vb, source%vb, nold, nsrc, lsource_mask) + call util_append(self%ah, source%ah, nold, nsrc, lsource_mask) + call util_append(self%aobl, source%aobl, nold, nsrc, lsource_mask) + call util_append(self%atide, source%atide, nold, nsrc, lsource_mask) + call util_append(self%agr, source%agr, nold, nsrc, lsource_mask) + call util_append(self%ir3h, source%ir3h, nold, nsrc, lsource_mask) + call util_append(self%a, source%a, nold, nsrc, lsource_mask) + call util_append(self%e, source%e, nold, nsrc, lsource_mask) + call util_append(self%inc, source%inc, nold, nsrc, lsource_mask) + call util_append(self%capom, source%capom, nold, nsrc, lsource_mask) + call util_append(self%omega, source%omega, nold, nsrc, lsource_mask) + call util_append(self%capm, source%capm, nold, nsrc, lsource_mask) + end associate self%nbody = count(self%status(:) /= INACTIVE) @@ -212,21 +184,23 @@ module subroutine util_append_pl(self, source, lsource_mask) select type(source) class is (swiftest_pl) - call util_append_body(self, source, lsource_mask) - - 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) + associate(nold => self%nbody, nsrc => source%nbody) + call util_append_body(self, source, lsource_mask) + + call util_append(self%mass, source%mass, nold, nsrc, lsource_mask) + call util_append(self%Gmass, source%Gmass, nold, nsrc, lsource_mask) + call util_append(self%rhill, source%rhill, nold, nsrc, lsource_mask) + call util_append(self%radius, source%radius, nold, nsrc, lsource_mask) + call util_append(self%xbeg, source%xbeg, nold, nsrc, lsource_mask) + call util_append(self%xend, source%xend, nold, nsrc, lsource_mask) + call util_append(self%vbeg, source%vbeg, nold, nsrc, lsource_mask) + call util_append(self%density, source%density, nold, nsrc, lsource_mask) + call util_append(self%Ip, source%Ip, nold, nsrc, lsource_mask) + call util_append(self%rot, source%rot, nold, nsrc, lsource_mask) + call util_append(self%k2, source%k2, nold, nsrc, lsource_mask) + call util_append(self%Q, source%Q, nold, nsrc, lsource_mask) + call util_append(self%tlag, source%tlag, nold, nsrc, lsource_mask) + end associate call self%eucl_index() class default @@ -251,11 +225,13 @@ module subroutine util_append_tp(self, source, lsource_mask) select type(source) class is (swiftest_tp) - call util_append_body(self, source, lsource_mask) + associate(nold => self%nbody, nsrc => source%nbody) + call util_append_body(self, source, 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%isperi, source%isperi, nold, nsrc, lsource_mask) + call util_append(self%peri, source%peri, nold, nsrc, lsource_mask) + call util_append(self%atp, source%atp, nold, nsrc, lsource_mask) + end associate class default write(*,*) "Invalid object passed to the append method. Source must be of class swiftest_tp or its descendents" call util_exit(FAILURE) diff --git a/src/whm/whm_util.f90 b/src/whm/whm_util.f90 index a71e4439c..777925889 100644 --- a/src/whm/whm_util.f90 +++ b/src/whm/whm_util.f90 @@ -15,13 +15,15 @@ module subroutine whm_util_append_pl(self, source, lsource_mask) select type(source) class is (whm_pl) - call util_append_pl(self, source, lsource_mask) - - 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) + associate(nold => self%nbody, nsrc => source%nbody) + call util_append_pl(self, source, lsource_mask) + + call util_append(self%eta, source%eta, nold, nsrc, lsource_mask) + call util_append(self%muj, source%muj, nold, nsrc, lsource_mask) + call util_append(self%ir3j, source%ir3j, nold, nsrc, lsource_mask) + call util_append(self%xj, source%xj, nold, nsrc, lsource_mask) + call util_append(self%vj, source%vj, nold, nsrc, lsource_mask) + end associate class default write(*,*) "Invalid object passed to the append method. Source must be of class whm_pl or its descendents" call util_exit(FAILURE)