From 86de607f52b9de460c1f93c70e0a61c977846d47 Mon Sep 17 00:00:00 2001 From: David A Minton Date: Mon, 30 Aug 2021 16:07:33 -0400 Subject: [PATCH] Switched out more associates with integers for number of bodies/events in subroutines where those numbers may change. --- src/discard/discard.f90 | 5 ++++- src/symba/symba_collision.f90 | 5 +++-- src/symba/symba_discard.f90 | 3 +++ src/symba/symba_encounter_check.f90 | 20 ++++++++++---------- src/symba/symba_kick.f90 | 26 +++++++++++++------------- src/symba/symba_util.f90 | 22 ++++++++-------------- 6 files changed, 41 insertions(+), 40 deletions(-) diff --git a/src/discard/discard.f90 b/src/discard/discard.f90 index e0dc8813e..97bbfbfc4 100644 --- a/src/discard/discard.f90 +++ b/src/discard/discard.f90 @@ -73,9 +73,12 @@ module subroutine discard_tp(self, system, param) class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameter ! Internals logical, dimension(:), allocatable :: ldiscard + integer(I4B) :: npl, ntp - associate(tp => self, ntp => self%nbody, cb => system%cb, pl => system%pl, npl => system%pl%nbody) + associate(tp => self, cb => system%cb, pl => system%pl) if ((ntp == 0) .or. (npl ==0)) return + ntp = tp%nbody + npl = pl%nbody if ((param%rmin >= 0.0_DP) .or. (param%rmax >= 0.0_DP) .or. & (param%rmaxu >= 0.0_DP) .or. ((param%qmin >= 0.0_DP) .and. (param%qmin_coord == "BARY"))) then diff --git a/src/symba/symba_collision.f90 b/src/symba/symba_collision.f90 index ae63edcba..15a52ac48 100644 --- a/src/symba/symba_collision.f90 +++ b/src/symba/symba_collision.f90 @@ -745,11 +745,12 @@ module subroutine symba_collision_encounter_extract_collisions(self, system, par logical, dimension(:), allocatable :: lplpl_unique_parent integer(I4B), dimension(:), pointer :: plparent integer(I4B), dimension(:), allocatable :: collision_idx, unique_parent_idx - integer(I4B) :: i, index_coll, ncollisions, nunique_parent + integer(I4B) :: i, index_coll, ncollisions, nunique_parent, nplplenc select type (pl => system%pl) class is (symba_pl) - associate(plplenc_list => self, nplplenc => self%nenc, idx1 => self%index1, idx2 => self%index2, plparent => pl%kin%parent) + associate(plplenc_list => self, idx1 => self%index1, idx2 => self%index2, plparent => pl%kin%parent) + nplplenc = plplenc_list%nenc allocate(lplpl_collision(nplplenc)) lplpl_collision(:) = plplenc_list%status(1:nplplenc) == COLLISION if (.not.any(lplpl_collision)) return diff --git a/src/symba/symba_discard.f90 b/src/symba/symba_discard.f90 index 877f7cc95..97a7f84ac 100644 --- a/src/symba/symba_discard.f90 +++ b/src/symba/symba_discard.f90 @@ -322,6 +322,9 @@ module subroutine symba_discard_pl(self, system, param) call symba_discard_nonplpl_conservation(self, system, param) + ! Save the add/discard information to file + call system%write_discard(param) + call pl%rearray(system, param) if (param%lenergy) then diff --git a/src/symba/symba_encounter_check.f90 b/src/symba/symba_encounter_check.f90 index 78403c348..3f5d8d00f 100644 --- a/src/symba/symba_encounter_check.f90 +++ b/src/symba/symba_encounter_check.f90 @@ -178,7 +178,7 @@ module function symba_encounter_check_tp(self, system, dt, irec) result(lany_enc logical :: lany_encounter !! Returns true if there is at least one close encounter ! Internals real(DP) :: r2crit, vdotr, r2, v2, tmin, r2min, term2 - integer(I4B) :: i, j, k,nenc + integer(I4B) :: i, j, k,nenc, plind, tpind real(DP), dimension(NDIM) :: xr, vr logical, dimension(:,:), allocatable :: lencounter, loc_lvdotr @@ -212,15 +212,15 @@ module function symba_encounter_check_tp(self, system, dt, irec) result(lany_enc class is (symba_pl) pl%lencounter(1:npl) = .false. do k = 1, nenc - associate(plind => pltpenc_list%index1(k), tpind => pltpenc_list%index2(k)) - pl%lencounter(plind) = .true. - pl%levelg(plind) = irec - pl%levelm(plind) = irec - tp%levelg(tpind) = irec - tp%levelm(tpind) = irec - pl%ntpenc(plind) = pl%ntpenc(plind) + 1 - tp%nplenc(tpind) = tp%nplenc(tpind) + 1 - end associate + plind = pltpenc_list%index1(k) + tpind = pltpenc_list%index2(k) + pl%lencounter(plind) = .true. + pl%levelg(plind) = irec + pl%levelm(plind) = irec + tp%levelg(tpind) = irec + tp%levelm(tpind) = irec + pl%ntpenc(plind) = pl%ntpenc(plind) + 1 + tp%nplenc(tpind) = tp%nplenc(tpind) + 1 end do end select end associate diff --git a/src/symba/symba_kick.f90 b/src/symba/symba_kick.f90 index c80f53536..2c074cb0d 100644 --- a/src/symba/symba_kick.f90 +++ b/src/symba/symba_kick.f90 @@ -77,7 +77,7 @@ module subroutine symba_kick_getacch_tp(self, system, param, t, lbeg) real(DP), intent(in) :: t !! Current time logical, intent(in) :: lbeg !! Logical flag that determines whether or not this is the beginning or end of the step ! Internals - integer(I4B) :: k + integer(I4B) :: i, j, k real(DP) :: rjj, fac, rlim2 real(DP), dimension(NDIM) :: dx @@ -88,18 +88,18 @@ module subroutine symba_kick_getacch_tp(self, system, param, t, lbeg) call helio_kick_getacch_tp(tp, system, param, t, lbeg) ! Remove accelerations from encountering pairs do k = 1, npltpenc - associate(i => pltpenc_list%index1(k), j => pltpenc_list%index2(k)) - if (tp%lmask(j)) THEN - if (lbeg) then - dx(:) = tp%xh(:,j) - pl%xbeg(:,i) - else - dx(:) = tp%xh(:,j) - pl%xend(:,i) - end if - rjj = dot_product(dx(:), dx(:)) - fac = pl%Gmass(i) / (rjj * sqrt(rjj)) - tp%ah(:,j) = tp%ah(:,j) + fac * dx(:) - end IF - end associate + i = pltpenc_list%index1(k) + j = pltpenc_list%index2(k) + if (tp%lmask(j)) THEN + if (lbeg) then + dx(:) = tp%xh(:,j) - pl%xbeg(:,i) + else + dx(:) = tp%xh(:,j) - pl%xend(:,i) + end if + rjj = dot_product(dx(:), dx(:)) + fac = pl%Gmass(i) / (rjj * sqrt(rjj)) + tp%ah(:,j) = tp%ah(:,j) + fac * dx(:) + end IF end do end associate end select diff --git a/src/symba/symba_util.f90 b/src/symba/symba_util.f90 index c805734bf..db8ff94ab 100644 --- a/src/symba/symba_util.f90 +++ b/src/symba/symba_util.f90 @@ -285,19 +285,19 @@ module subroutine symba_util_index_eucl_plpl(self, param) class(symba_pl), intent(inout) :: self !! SyMBA massive body object class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters ! Internals - integer(I8B) :: i, j, counter, npl, nplm + integer(I8B) :: i, j, counter, npl, nplm, nplpl, nplplm - associate(pl => self, nplpl => self%nplpl, nplplm => self%nplplm) + associate(pl => self) npl = int(self%nbody, kind=I8B) call pl%sort("mass", ascending=.false.) nplm = count(.not. pl%lmtiny(1:npl)) pl%nplm = int(nplm, kind=I4B) - nplpl = (npl * (npl - 1) / 2) ! number of entries in a strict lower triangle, npl x npl, minus first column - nplplm = nplm * npl - nplm * (nplm + 1) / 2 ! number of entries in a strict lower triangle, npl x npl, minus first column including only mutually interacting bodies + pl%nplpl = (npl * (npl - 1) / 2) ! number of entries in a strict lower triangle, npl x npl, minus first column + pl%nplplm = nplm * npl - nplm * (nplm + 1) / 2 ! number of entries in a strict lower triangle, npl x npl, minus first column including only mutually interacting bodies if (allocated(self%k_plpl)) deallocate(self%k_plpl) ! Reset the index array if it's been set previously - allocate(self%k_plpl(2, nplpl)) + allocate(self%k_plpl(2, pl%nplpl)) do i = 1, npl counter = (i - 1_I8B) * npl - i * (i - 1_I8B) / 2_I8B + 1_I8B do j = i + 1_I8B, npl @@ -418,7 +418,7 @@ module subroutine symba_util_rearray_pl(self, system, param) associate(pl => self, pl_adds => system%pl_adds) npl = pl%nbody - nadd = pl_adds%nbody) + nadd = pl_adds%nbody if (npl == 0) return ! Deallocate any temporary variables if (allocated(pl%xbeg)) deallocate(pl%xbeg) @@ -431,7 +431,7 @@ module subroutine symba_util_rearray_pl(self, system, param) call pl%spill(tmp, lspill_list=lmask, ldestructive=.true.) npl = pl%nbody call tmp%setup(0,param) - if (allocated(tmp)) deallocate(tmp) + deallocate(tmp) deallocate(lmask) ! Store the original plplenc list so we don't remove any of the original encounters @@ -869,8 +869,6 @@ module subroutine symba_util_spill_pl(self, discards, lspill_list, ldestructive) 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 body by removing the discard list - ! 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 @@ -911,10 +909,8 @@ module subroutine symba_util_spill_encounter(self, discards, lspill_list, ldestr class(swiftest_encounter), 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 body by removing the discard list - ! Internals - integer(I4B) :: i - associate(keeps => self, nenc => self%nenc) + associate(keeps => self) select type(discards) class is (symba_encounter) call util_spill(keeps%level, discards%level, lspill_list, ldestructive) @@ -940,8 +936,6 @@ module subroutine symba_util_spill_tp(self, discards, lspill_list, ldestructive) 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 body by removing the discard list - ! 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