Skip to content
This repository was archived by the owner on Aug 28, 2024. It is now read-only.

Commit

Permalink
Improved handling of appends
Browse files Browse the repository at this point in the history
  • Loading branch information
@daminton
daminton committed Aug 10, 2021
1 parent 49ca22a commit 741971e
Show file tree
Hide file tree
Showing 7 changed files with 171 additions and 185 deletions.
17 changes: 11 additions & 6 deletions src/modules/swiftest_classes.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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

Expand Down
6 changes: 4 additions & 2 deletions src/modules/symba_classes.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
30 changes: 17 additions & 13 deletions src/rmvs/rmvs_util.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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)
Expand Down
3 changes: 3 additions & 0 deletions src/symba/symba_fragmentation.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
104 changes: 49 additions & 55 deletions src/symba/symba_util.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,63 +2,51 @@
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.
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
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.
implicit none
! 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
Expand All @@ -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)
Expand All @@ -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
Expand All @@ -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)
Expand Down
Loading

0 comments on commit 741971e

Please sign in to comment.