diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 95ee7e9a0..92784193d 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -13,55 +13,59 @@ # Add the source files SET(FAST_MATH_FILES - ${SRC}/modules/swiftest_globals.f90 + ${SRC}/modules/globals.f90 + ${SRC}/modules/base.f90 + ${SRC}/modules/encounter.f90 + ${SRC}/modules/collision.f90 + ${SRC}/modules/fraggle.f90 ${SRC}/modules/lambda_function.f90 - ${SRC}/modules/swiftest_operators.f90 - ${SRC}/modules/walltime_classes.f90 - ${SRC}/modules/swiftest_classes.f90 - ${SRC}/modules/encounter_classes.f90 - ${SRC}/modules/collision_classes.f90 - ${SRC}/modules/fraggle_classes.f90 - ${SRC}/modules/helio_classes.f90 - ${SRC}/modules/rmvs_classes.f90 - ${SRC}/modules/symba_classes.f90 - ${SRC}/modules/whm_classes.f90 + ${SRC}/modules/operators.f90 + ${SRC}/modules/walltime.f90 + ${SRC}/modules/io_progress_bar.f90 ${SRC}/modules/swiftest.f90 - ${SRC}/collision/collision_io.f90 - ${SRC}/collision/collision_regime.f90 + ${SRC}/modules/whm.f90 + ${SRC}/modules/rmvs.f90 + ${SRC}/modules/helio.f90 + ${SRC}/modules/symba.f90 + ${SRC}/swiftest_procedures/swiftest_discard.f90 + ${SRC}/swiftest_procedures/swiftest_io.f90 + ${SRC}/swiftest_procedures/swiftest_obl.f90 + ${SRC}/swiftest_procedures/swiftest_util.f90 + ${SRC}/swiftest_procedures/swiftest_drift.f90 + ${SRC}/swiftest_procedures/swiftest_io_netcdf.f90 + ${SRC}/swiftest_procedures/swiftest_orbel.f90 + ${SRC}/swiftest_procedures/swiftest_gr.f90 + ${SRC}/swiftest_procedures/swiftest_kick.f90 + ${SRC}/swiftest_procedures/swiftest_setup.f90 + ${SRC}/collision/collision_check.f90 + ${SRC}/collision/collision_regime.f90 ${SRC}/collision/collision_setup.f90 + ${SRC}/collision/collision_io.f90 + ${SRC}/collision/collision_resolve.f90 ${SRC}/collision/collision_util.f90 - ${SRC}/discard/discard.f90 - ${SRC}/drift/drift.f90 ${SRC}/encounter/encounter_check.f90 + ${SRC}/encounter/encounter_io.f90 ${SRC}/encounter/encounter_setup.f90 ${SRC}/encounter/encounter_util.f90 - ${SRC}/encounter/encounter_io.f90 ${SRC}/fraggle/fraggle_generate.f90 ${SRC}/fraggle/fraggle_io.f90 + ${SRC}/fraggle/fraggle_resolve.f90 ${SRC}/fraggle/fraggle_set.f90 ${SRC}/fraggle/fraggle_setup.f90 ${SRC}/fraggle/fraggle_util.f90 - ${SRC}/gr/gr.f90 ${SRC}/helio/helio_drift.f90 ${SRC}/helio/helio_gr.f90 ${SRC}/helio/helio_setup.f90 ${SRC}/helio/helio_step.f90 ${SRC}/helio/helio_util.f90 - ${SRC}/io/io.f90 - ${SRC}/io/io_progress_bar.f90 - ${SRC}/netcdf/netcdf.f90 - ${SRC}/obl/obl.f90 ${SRC}/operators/operator_cross.f90 ${SRC}/operators/operator_mag.f90 ${SRC}/operators/operator_unit.f90 - ${SRC}/orbel/orbel.f90 ${SRC}/rmvs/rmvs_discard.f90 ${SRC}/rmvs/rmvs_encounter_check.f90 ${SRC}/rmvs/rmvs_setup.f90 ${SRC}/rmvs/rmvs_step.f90 ${SRC}/rmvs/rmvs_util.f90 - ${SRC}/setup/setup.f90 - ${SRC}/symba/symba_collision.f90 ${SRC}/symba/symba_discard.f90 ${SRC}/symba/symba_drift.f90 ${SRC}/symba/symba_encounter_check.f90 @@ -73,30 +77,7 @@ SET(FAST_MATH_FILES ${SRC}/tides/tides_getacch_pl.f90 ${SRC}/tides/tides_spin_step.f90 ${SRC}/user/user_getacch.f90 - ${SRC}/util/util_append.f90 - ${SRC}/util/util_coord.f90 - ${SRC}/util/util_copy.f90 - ${SRC}/util/util_dealloc.f90 - ${SRC}/util/util_exit.f90 - ${SRC}/util/util_fill.f90 - ${SRC}/util/util_final.f90 - ${SRC}/util/util_flatten.f90 - ${SRC}/util/util_get_energy_momentum.f90 - ${SRC}/util/util_index.f90 - ${SRC}/util/util_minimize_bfgs.f90 - ${SRC}/util/util_peri.f90 - ${SRC}/util/util_rescale.f90 - ${SRC}/util/util_reset.f90 - ${SRC}/util/util_resize.f90 - ${SRC}/util/util_set.f90 - ${SRC}/util/util_snapshot.f90 - ${SRC}/util/util_solve.f90 - ${SRC}/util/util_sort.f90 - ${SRC}/util/util_spill.f90 - ${SRC}/util/util_unique.f90 - ${SRC}/util/util_valid.f90 - ${SRC}/util/util_version.f90 - ${SRC}/walltime/walltime.f90 + ${SRC}/walltime/walltime_implementations.f90 ${SRC}/whm/whm_coord.f90 ${SRC}/whm/whm_drift.f90 ${SRC}/whm/whm_gr.f90 @@ -105,8 +86,9 @@ SET(FAST_MATH_FILES ${SRC}/whm/whm_util.f90 ${SRC}/main/swiftest_driver.f90 ) + SET(STRICT_MATH_FILES - ${SRC}/kick/kick.f90 + ${SRC}/swiftest_procedures/swiftest_kick.f90 ${SRC}/helio/helio_kick.f90 ${SRC}/rmvs/rmvs_kick.f90 ${SRC}/symba/symba_kick.f90 diff --git a/src/collision/collision_check.f90 b/src/collision/collision_check.f90 new file mode 100644 index 000000000..290773032 --- /dev/null +++ b/src/collision/collision_check.f90 @@ -0,0 +1,263 @@ + +!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh +!! This file is part of Swiftest. +!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License +!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. +!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty +!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. +!! You should have received a copy of the GNU General Public License along with Swiftest. +!! If not, see: https://www.gnu.org/licenses. + +submodule (collision) s_collision_check + use swiftest +contains + + pure elemental subroutine collision_check_one(xr, yr, zr, vxr, vyr, vzr, Gmtot, rlim, dt, lvdotr, lcollision, lclosest) + !! author: David A. Minton + !! + !! Check for a merger between a single pair of particles + !! + !! Adapted from David E. Kaufmann's Swifter routines symba_merge_tp.f90 and symba_merge_pl.f90 + !! + !! Adapted from Hal Levison's Swift routine symba5_merge.f + implicit none + ! Arguments + real(DP), intent(in) :: xr, yr, zr !! Relative position vector components + real(DP), intent(in) :: vxr, vyr, vzr !! Relative velocity vector components + real(DP), intent(in) :: Gmtot !! Sum of G*mass of colliding bodies + real(DP), intent(in) :: rlim !! Collision limit - Typically the sum of the radii of colliding bodies + real(DP), intent(in) :: dt !! Step size + logical, intent(in) :: lvdotr !! Logical flag indicating that these two bodies are approaching in the current substep + logical, intent(out) :: lcollision !! Logical flag indicating whether these two bodies will collide or not + logical, intent(out) :: lclosest !! Logical flag indicating that, while not a collision, this is the closest approach for this pair of bodies + ! Internals + real(DP) :: r2, rlim2, a, e, q, vdotr, tcr2, dt2 + + r2 = xr**2 + yr**2 + zr**2 + rlim2 = rlim**2 + lclosest = .false. + if (r2 <= rlim2) then ! checks if bodies are actively colliding in this time step + lcollision = .true. + else ! if they are not actively colliding in this time step, checks if they are going to collide next time step based on velocities and q + lcollision = .false. + vdotr = xr * vxr + yr * vyr + zr * vzr + if (lvdotr .and. (vdotr > 0.0_DP)) then + tcr2 = r2 / (vxr**2 + vyr**2 + vzr**2) + dt2 = dt**2 + if (tcr2 <= dt2) then + call swiftest_orbel_xv2aeq(Gmtot, xr, yr, zr, vxr, vyr, vzr, a, e, q) + lcollision = (q < rlim) + end if + lclosest = .not. lcollision + end if + end if + + return + end subroutine collision_check_one + + + module subroutine collision_check_plpl(self, system, param, t, dt, irec, lany_collision) + !! author: David A. Minton + !! + !! Check for merger between massive bodies and test particles in SyMBA + !! + !! Adapted from David E. Kaufmann's Swifter routine symba_merge.f90 and symba_merge_tp.f90 + !! + !! Adapted from Hal Levison's Swift routine symba5_merge.f + implicit none + ! Arguments + class(collision_list_plpl), intent(inout) :: self !! SyMBA pl-tp encounter list object + class(base_nbody_system), intent(inout) :: system !! SyMBA nbody system object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + real(DP), intent(in) :: t !! current time + real(DP), intent(in) :: dt !! step size + integer(I4B), intent(in) :: irec !! Current recursion level + logical, intent(out) :: lany_collision !! Returns true if cany pair of encounters resulted in a collision + ! Internals + logical, dimension(:), allocatable :: lcollision, lmask + real(DP), dimension(NDIM) :: xr, vr + integer(I4B) :: i, j, k, nenc + real(DP) :: rlim, Gmtot + logical :: isplpl, lany_closest + character(len=STRMAX) :: timestr, idstri, idstrj, message + class(collision_list_plpl), allocatable :: tmp + + lany_collision = .false. + if (self%nenc == 0) return + + select type(system) + class is (swiftest_nbody_system) + associate(pl => system%pl) + + nenc = self%nenc + allocate(lmask(nenc)) + ! TODO: Move this to a SyMBA-specific method + ! lmask(:) = ((self%status(1:nenc) == ACTIVE) .and. (pl%levelg(self%index1(1:nenc)) >= irec)) + ! if (isplpl) then + ! lmask(:) = lmask(:) .and. (pl%levelg(self%index2(1:nenc)) >= irec) + ! else + ! lmask(:) = lmask(:) .and. (tp%levelg(self%index2(1:nenc)) >= irec) + ! end if + ! if (.not.any(lmask(:))) return + + allocate(lcollision(nenc)) + lcollision(:) = .false. + self%lclosest(:) = .false. + + do concurrent(k = 1:nenc, lmask(k)) + i = self%index1(k) + j = self%index2(k) + xr(:) = pl%rh(:, i) - pl%rh(:, j) + vr(:) = pl%vb(:, i) - pl%vb(:, j) + rlim = pl%radius(i) + pl%radius(j) + Gmtot = pl%Gmass(i) + pl%Gmass(j) + call collision_check_one(xr(1), xr(2), xr(3), vr(1), vr(2), vr(3), Gmtot, rlim, dt, self%lvdotr(k), lcollision(k), self%lclosest(k)) + end do + + lany_collision = any(lcollision(:)) + !lany_closest = (param%lenc_save_closest .and. any(self%lclosest(:))) + + + if (lany_collision .or. lany_closest) then + call pl%rh2rb(system%cb) ! Update the central body barycenteric position vector to get us out of DH and into bary + do k = 1, nenc + if (.not.lcollision(k) .and. .not. self%lclosest(k)) cycle + i = self%index1(k) + j = self%index2(k) + self%r1(:,k) = pl%rh(:,i) + system%cb%rb(:) + self%v1(:,k) = pl%vb(:,i) + if (lcollision(k)) then + self%status(k) = COLLIDED + self%tcollision(k) = t + end if + self%r2(:,k) = pl%rh(:,j) + system%cb%rb(:) + self%v2(:,k) = pl%vb(:,j) + if (lcollision(k)) then + ! Check to see if either of these bodies has been involved with a collision before, and if so, make this a collider pair + if (pl%lcollision(i) .or. pl%lcollision(j)) call pl%make_impactors([i,j]) + + ! Set the collision flag for these to bodies to true in case they become involved in another collision later in the step + pl%lcollision([i, j]) = .true. + pl%status([i, j]) = COLLIDED + call pl%info(i)%set_value(status="COLLIDED") + call pl%info(j)%set_value(status="COLLIDED") + end if + + end do + + ! Extract the pl-pl encounter list and return the pl-pl collision_list + call self%extract_collisions(system, param) + end if + + ! Take snapshots of pairs of bodies at close approach (but not collision) if requested + if (lany_closest) call system%encounter_history%take_snapshot(param, system, t, "closest") + + end associate + end select + return + end subroutine collision_check_plpl + + + module subroutine collision_check_pltp(self, system, param, t, dt, irec, lany_collision) + !! author: David A. Minton + !! + !! Check for merger between massive bodies and test particles in SyMBA + !! + !! Adapted from David E. Kaufmann's Swifter routine symba_merge.f90 and symba_merge_tp.f90 + !! + !! Adapted from Hal Levison's Swift routine symba5_merge.f + implicit none + ! Arguments + class(collision_list_pltp), intent(inout) :: self !! SyMBA pl-tp encounter list object + class(base_nbody_system), intent(inout) :: system !! SyMBA nbody system object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + real(DP), intent(in) :: t !! current time + real(DP), intent(in) :: dt !! step size + integer(I4B), intent(in) :: irec !! Current recursion level + logical, intent(out) :: lany_collision !! Returns true if cany pair of encounters resulted in a collision + ! Internals + logical, dimension(:), allocatable :: lcollision, lmask + real(DP), dimension(NDIM) :: xr, vr + integer(I4B) :: i, j, k, nenc + real(DP) :: rlim + logical :: lany_closest + character(len=STRMAX) :: timestr, idstri, idstrj, message + class(collision_list_pltp), allocatable :: tmp + + lany_collision = .false. + if (self%nenc == 0) return + select type(system) + class is (swiftest_nbody_system) + select type(param) + class is (swiftest_parameters) + + associate(pl => system%pl, tp => system%tp) + + nenc = self%nenc + allocate(lmask(nenc)) + ! TODO: Move this to a SyMBA-specific method + ! lmask(:) = ((self%status(1:nenc) == ACTIVE) .and. (pl%levelg(self%index1(1:nenc)) >= irec)) + ! lmask(:) = lmask(:) .and. (tp%levelg(self%index2(1:nenc)) >= irec) + ! if (.not.any(lmask(:))) return + + allocate(lcollision(nenc)) + lcollision(:) = .false. + self%lclosest(:) = .false. + + + do concurrent(k = 1:nenc, lmask(k)) + i = self%index1(k) + j = self%index2(k) + xr(:) = pl%rh(:, i) - tp%rh(:, j) + vr(:) = pl%vb(:, i) - tp%vb(:, j) + call collision_check_one(xr(1), xr(2), xr(3), vr(1), vr(2), vr(3), pl%Gmass(i), pl%radius(i), dt, self%lvdotr(k), lcollision(k), self%lclosest(k)) + end do + + lany_collision = any(lcollision(:)) + lany_closest = (param%lenc_save_closest .and. any(self%lclosest(:))) + + + if (lany_collision .or. lany_closest) then + call pl%rh2rb(system%cb) ! Update the central body barycenteric position vector to get us out of DH and into bary + do k = 1, nenc + if (.not.lcollision(k) .and. .not. self%lclosest(k)) cycle + i = self%index1(k) + j = self%index2(k) + self%r1(:,k) = pl%rh(:,i) + system%cb%rb(:) + self%v1(:,k) = pl%vb(:,i) + if (lcollision(k)) then + self%status(k) = COLLIDED + self%tcollision(k) = t + end if + + self%r2(:,k) = tp%rh(:,j) + system%cb%rb(:) + self%v2(:,k) = tp%vb(:,j) + if (lcollision(k)) then + tp%status(j) = DISCARDED_PLR + tp%ldiscard(j) = .true. + write(idstri, *) pl%id(i) + write(idstrj, *) tp%id(j) + write(timestr, *) t + call tp%info(j)%set_value(status="DISCARDED_PLR", discard_time=t, discard_rh=tp%rh(:,j), discard_vh=tp%vh(:,j)) + write(message, *) "Particle " // trim(adjustl(tp%info(j)%name)) // " (" // trim(adjustl(idstrj)) // ")" & + // " collided with massive body " // trim(adjustl(pl%info(i)%name)) // " (" // trim(adjustl(idstri)) // ")" & + // " at t = " // trim(adjustl(timestr)) + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, message) + end if + end do + + ! Extract the pl-tp encounter list and return the pl-tp collision_list + allocate(tmp, mold=self) + call self%spill(tmp, lcollision, ldestructive=.true.) ! Remove this encounter pair from the encounter list + end if + + ! Take snapshots of pairs of bodies at close approach (but not collision) if requested + if (lany_closest) call system%encounter_history%take_snapshot(param, system, t, "closest") + end associate + end select + end select + + return + end subroutine collision_check_pltp + +end submodule s_collision_check \ No newline at end of file diff --git a/src/collision/collision_io.f90 b/src/collision/collision_io.f90 index 5afb3ab8e..2c5abd7b9 100644 --- a/src/collision/collision_io.f90 +++ b/src/collision/collision_io.f90 @@ -7,54 +7,55 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(collision_classes) s_collision_io +submodule(collision) s_collision_io use swiftest contains + module subroutine collision_io_dump(self, param) + !! author: David A. Minton + !! + !! Dumps the time history of an encounter to file. + implicit none + ! Arguments + class(collision_storage(*)), intent(inout) :: self !! Encounter storage object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + ! Internals + integer(I4B) :: i + select type(nc => self%nc) + class is (collision_io_parameters) + select type(param) + class is (swiftest_parameters) + if (self%iframe > 0) then + nc%file_number = nc%file_number + 1 + call self%make_index_map() + nc%event_dimsize = self%nt + nc%name_dimsize = self%nid + + write(nc%file_name, '("collision_",I0.6,".nc")') nc%file_number + call nc%initialize(param) + + do i = 1, self%nframes + if (allocated(self%frame(i)%item)) then + select type(snapshot => self%frame(i)%item) + class is (collision_snapshot) + param%ioutput = i + call snapshot%write_frame(self,param) + end select + else + exit + end if + end do -module subroutine collision_io_dump(self, param) - !! author: David A. Minton - !! - !! Dumps the time history of an encounter to file. - implicit none - ! Arguments - class(collision_storage(*)), intent(inout) :: self !! Encounter storage object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - ! Internals - integer(I4B) :: i - - select type(nc => self%nc) - class is (collision_io_parameters) - if (self%iframe > 0) then - nc%file_number = nc%file_number + 1 - call self%make_index_map() - nc%event_dimsize = self%nt - nc%name_dimsize = self%nid - - write(nc%file_name, '("collision_",I0.6,".nc")') nc%file_number - call nc%initialize(param) - - do i = 1, self%nframes - if (allocated(self%frame(i)%item)) then - select type(snapshot => self%frame(i)%item) - class is (collision_snapshot) - param%ioutput = i - call snapshot%write_frame(nc,param) - end select - else - exit - end if - end do - - call nc%close() - call self%reset() - end if - end select + call nc%close() + call self%reset() + end if + end select + end select - return -end subroutine collision_io_dump + return + end subroutine collision_io_dump module subroutine collision_io_initialize_output(self, param) !! author: David A. Minton @@ -65,7 +66,7 @@ module subroutine collision_io_initialize_output(self, param) implicit none ! Arguments class(collision_io_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset - class(swiftest_parameters), intent(in) :: param + class(base_parameters), intent(in) :: param ! Internals integer(I4B) :: nvar, varid, vartype real(DP) :: dfill @@ -76,8 +77,8 @@ module subroutine collision_io_initialize_output(self, param) integer(I4B) :: ndims select type(param) - class is (symba_parameters) - associate(nc => self, collision_history => param%collision_history) + class is (base_parameters) + associate(nc => self) dfill = ieee_value(dfill, IEEE_QUIET_NAN) sfill = ieee_value(sfill, IEEE_QUIET_NAN) @@ -95,93 +96,93 @@ module subroutine collision_io_initialize_output(self, param) close(unit=LUN, status="delete") end if - call check( nf90_create(nc%file_name, NF90_NETCDF4, nc%id), "collision_io_initialize_output nf90_create" ) + call netcdf_check( nf90_create(nc%file_name, NF90_NETCDF4, nc%id), "collision_io_initialize_output nf90_create" ) ! Dimensions - call check( nf90_def_dim(nc%id, nc%event_dimname, nc%event_dimsize, nc%event_dimid), "collision_io_initialize_output nf90_def_dim event_dimid" ) ! Dimension to store individual collision events - call check( nf90_def_dim(nc%id, nc%space_dimname, NDIM, nc%space_dimid), "collision_io_initialize_output nf90_def_dim space_dimid" ) ! 3D space dimension - call check( nf90_def_dim(nc%id, nc%name_dimname, nc%name_dimsize, nc%name_dimid), "collision_io_initialize_output nf90_def_dim name_dimid" ) ! Dimension to store particle id numbers - call check( nf90_def_dim(nc%id, nc%str_dimname, NAMELEN, nc%str_dimid), "collision_io_initialize_output nf90_def_dim str_dimid" ) ! Dimension for string variables (aka character arrays) - call check( nf90_def_dim(nc%id, nc%stage_dimname, 2, nc%stage_dimid), "collision_io_initialize_output nf90_def_dim stage_dimid" ) ! Dimension for stage variables (aka "before" vs. "after" + call netcdf_check( nf90_def_dim(nc%id, nc%event_dimname, nc%event_dimsize, nc%event_dimid), "collision_io_initialize_output nf90_def_dim event_dimid" ) ! Dimension to store individual collision events + call netcdf_check( nf90_def_dim(nc%id, nc%space_dimname, NDIM, nc%space_dimid), "collision_io_initialize_output nf90_def_dim space_dimid" ) ! 3D space dimension + call netcdf_check( nf90_def_dim(nc%id, nc%name_dimname, nc%name_dimsize, nc%name_dimid), "collision_io_initialize_output nf90_def_dim name_dimid" ) ! Dimension to store particle id numbers + call netcdf_check( nf90_def_dim(nc%id, nc%str_dimname, NAMELEN, nc%str_dimid), "collision_io_initialize_output nf90_def_dim str_dimid" ) ! Dimension for string variables (aka character arrays) + call netcdf_check( nf90_def_dim(nc%id, nc%stage_dimname, 2, nc%stage_dimid), "collision_io_initialize_output nf90_def_dim stage_dimid" ) ! Dimension for stage variables (aka "before" vs. "after" ! Dimension coordinates - call check( nf90_def_var(nc%id, nc%space_dimname, NF90_CHAR, nc%space_dimid, nc%space_varid), "collision_io_initialize_output nf90_def_var space_varid" ) - call check( nf90_def_var(nc%id, nc%name_dimname, NF90_CHAR, [nc%str_dimid, nc%name_dimid], nc%name_varid), "collision_io_initialize_output nf90_def_var name_varid") - call check( nf90_def_var(nc%id, nc%stage_dimname, NF90_CHAR, [nc%str_dimid, nc%stage_dimid], nc%stage_varid), "collision_io_initialize_output nf90_def_var stage_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%space_dimname, NF90_CHAR, nc%space_dimid, nc%space_varid), "collision_io_initialize_output nf90_def_var space_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%name_dimname, NF90_CHAR, [nc%str_dimid, nc%name_dimid], nc%name_varid), "collision_io_initialize_output nf90_def_var name_varid") + call netcdf_check( nf90_def_var(nc%id, nc%stage_dimname, NF90_CHAR, [nc%str_dimid, nc%stage_dimid], nc%stage_varid), "collision_io_initialize_output nf90_def_var stage_varid" ) ! Variables - call check( nf90_def_var(nc%id, nc%id_varname, NF90_INT, nc%name_dimid, nc%id_varid), "collision_io_initialize_output nf90_def_var id_varid" ) - call check( nf90_def_var(nc%id, nc%time_dimname, nc%out_type, & + call netcdf_check( nf90_def_var(nc%id, nc%id_varname, NF90_INT, nc%name_dimid, nc%id_varid), "collision_io_initialize_output nf90_def_var id_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%time_dimname, nc%out_type, & nc%event_dimid, nc%time_varid), "collision_io_initialize_output nf90_def_var time_varid" ) - call check( nf90_def_var(nc%id, nc%regime_varname, NF90_CHAR, & + call netcdf_check( nf90_def_var(nc%id, nc%regime_varname, NF90_CHAR, & [nc%str_dimid, nc%event_dimid], nc%regime_varid), "collision_io_initialize_output nf90_def_var regime_varid") - call check( nf90_def_var(nc%id, nc%Qloss_varname, nc%out_type, & + call netcdf_check( nf90_def_var(nc%id, nc%Qloss_varname, nc%out_type, & [ nc%event_dimid], nc%Qloss_varid), "collision_io_initialize_output nf90_def_var Qloss_varid") - call check( nf90_def_var(nc%id, nc%ptype_varname, NF90_CHAR, & + call netcdf_check( nf90_def_var(nc%id, nc%ptype_varname, NF90_CHAR, & [nc%str_dimid, nc%name_dimid, nc%stage_dimid, nc%event_dimid], nc%ptype_varid), "collision_io_initialize_output nf90_def_var ptype_varid") - call check( nf90_def_var(nc%id, nc%loop_varname, NF90_INT, & + call netcdf_check( nf90_def_var(nc%id, nc%loop_varname, NF90_INT, & [ nc%event_dimid], nc%loop_varid), "collision_io_initialize_output nf90_def_var loop_varid") - call check( nf90_def_var(nc%id, nc%rh_varname, nc%out_type,& + call netcdf_check( nf90_def_var(nc%id, nc%rh_varname, nc%out_type,& [ nc%space_dimid, nc%name_dimid, nc%stage_dimid, nc%event_dimid], nc%rh_varid), "collision_io_initialize_output nf90_def_var rh_varid") - call check( nf90_def_var(nc%id, nc%vh_varname, nc%out_type,& + call netcdf_check( nf90_def_var(nc%id, nc%vh_varname, nc%out_type,& [ nc%space_dimid, nc%name_dimid, nc%stage_dimid, nc%event_dimid], nc%vh_varid), "collision_io_initialize_output nf90_def_var vh_varid") - call check( nf90_def_var(nc%id, nc%Gmass_varname, nc%out_type,& + call netcdf_check( nf90_def_var(nc%id, nc%Gmass_varname, nc%out_type,& [ nc%name_dimid, nc%stage_dimid, nc%event_dimid], nc%Gmass_varid), "collision_io_initialize_output nf90_def_var Gmass_varid") - call check( nf90_def_var(nc%id, nc%radius_varname, nc%out_type,& + call netcdf_check( nf90_def_var(nc%id, nc%radius_varname, nc%out_type,& [ nc%name_dimid, nc%stage_dimid, nc%event_dimid], nc%radius_varid), "collision_io_initialize_output nf90_def_var radius_varid") - call check( nf90_def_var(nc%id, nc%Ip_varname, nc%out_type,& + call netcdf_check( nf90_def_var(nc%id, nc%Ip_varname, nc%out_type,& [ nc%space_dimid, nc%name_dimid, nc%stage_dimid, nc%event_dimid], nc%Ip_varid), "collision_io_initialize_output nf90_def_var Ip_varid") - call check( nf90_def_var(nc%id, nc%rot_varname, nc%out_type,& + call netcdf_check( nf90_def_var(nc%id, nc%rot_varname, nc%out_type,& [ nc%space_dimid, nc%name_dimid, nc%stage_dimid, nc%event_dimid], nc%rot_varid), "collision_io_initialize_output nf90_def_var rot_varid") if (param%lenergy) then - call check( nf90_def_var(nc%id, nc%ke_orb_varname, nc%out_type,& + call netcdf_check( nf90_def_var(nc%id, nc%ke_orb_varname, nc%out_type,& [ nc%stage_dimid, nc%event_dimid], nc%KE_orb_varid), "collision_io_initialize_output nf90_def_var KE_orb_varid") - call check( nf90_def_var(nc%id, nc%ke_spin_varname, nc%out_type,& + call netcdf_check( nf90_def_var(nc%id, nc%ke_spin_varname, nc%out_type,& [ nc%stage_dimid, nc%event_dimid], nc%KE_spin_varid), "collision_io_initialize_output nf90_def_var KE_spin_varid" ) - call check( nf90_def_var(nc%id, nc%pe_varname, nc%out_type,& + call netcdf_check( nf90_def_var(nc%id, nc%pe_varname, nc%out_type,& [ nc%stage_dimid, nc%event_dimid], nc%PE_varid), "collision_io_initialize_output nf90_def_var PE_varid" ) - call check( nf90_def_var(nc%id, nc%L_orb_varname, nc%out_type, & + call netcdf_check( nf90_def_var(nc%id, nc%L_orb_varname, nc%out_type, & [ nc%space_dimid, nc%stage_dimid, nc%event_dimid], nc%L_orb_varid), "collision_io_initialize_output nf90_def_var L_orb_varid" ) - call check( nf90_def_var(nc%id, nc%Lspin_varname, nc%out_type,& + call netcdf_check( nf90_def_var(nc%id, nc%Lspin_varname, nc%out_type,& [ nc%space_dimid, nc%stage_dimid, nc%event_dimid], nc%Lspin_varid), "collision_io_initialize_output nf90_def_var Lspin_varid" ) end if - call check( nf90_inquire(nc%id, nVariables=nvar), "collision_io_initialize_output nf90_inquire nVariables" ) + call netcdf_check( nf90_inquire(nc%id, nVariables=nvar), "collision_io_initialize_output nf90_inquire nVariables" ) do varid = 1, nvar - call check( nf90_inquire_variable(nc%id, varid, xtype=vartype, ndims=ndims), "collision_io_initialize_output nf90_inquire_variable" ) + call netcdf_check( nf90_inquire_variable(nc%id, varid, xtype=vartype, ndims=ndims), "collision_io_initialize_output nf90_inquire_variable" ) select case(vartype) case(NF90_INT) - call check( nf90_def_var_fill(nc%id, varid, NO_FILL, NF90_FILL_INT), "collision_io_initialize_output nf90_def_var_fill NF90_INT" ) + call netcdf_check( nf90_def_var_fill(nc%id, varid, NO_FILL, NF90_FILL_INT), "collision_io_initialize_output nf90_def_var_fill NF90_INT" ) case(NF90_FLOAT) - call check( nf90_def_var_fill(nc%id, varid, NO_FILL, sfill), "collision_io_initialize_output nf90_def_var_fill NF90_FLOAT" ) + call netcdf_check( nf90_def_var_fill(nc%id, varid, NO_FILL, sfill), "collision_io_initialize_output nf90_def_var_fill NF90_FLOAT" ) case(NF90_DOUBLE) - call check( nf90_def_var_fill(nc%id, varid, NO_FILL, dfill), "collision_io_initialize_output nf90_def_var_fill NF90_DOUBLE" ) + call netcdf_check( nf90_def_var_fill(nc%id, varid, NO_FILL, dfill), "collision_io_initialize_output nf90_def_var_fill NF90_DOUBLE" ) case(NF90_CHAR) - call check( nf90_def_var_fill(nc%id, varid, NO_FILL, 0), "collision_io_initialize_output nf90_def_var_fill NF90_CHAR" ) + call netcdf_check( nf90_def_var_fill(nc%id, varid, NO_FILL, 0), "collision_io_initialize_output nf90_def_var_fill NF90_CHAR" ) end select end do ! Take the file out of define mode - call check( nf90_enddef(nc%id), "collision_io_initialize_output nf90_enddef" ) + call netcdf_check( nf90_enddef(nc%id), "collision_io_initialize_output nf90_enddef" ) ! Add in the space and stage dimension coordinates - call check( nf90_put_var(nc%id, nc%space_varid, nc%space_coords, start=[1], count=[NDIM]), "collision_io_initialize_output nf90_put_var space" ) - call check( nf90_put_var(nc%id, nc%stage_varid, nc%stage_coords(1), start=[1,1], count=[len(nc%stage_coords(1)),1]), "collision_io_initialize_output nf90_put_var stage 1" ) - call check( nf90_put_var(nc%id, nc%stage_varid, nc%stage_coords(2), start=[1,2], count=[len(nc%stage_coords(2)),1]), "collision_io_initialize_output nf90_put_var stage 2" ) + call netcdf_check( nf90_put_var(nc%id, nc%space_varid, nc%space_coords, start=[1], count=[NDIM]), "collision_io_initialize_output nf90_put_var space" ) + call netcdf_check( nf90_put_var(nc%id, nc%stage_varid, nc%stage_coords(1), start=[1,1], count=[len(nc%stage_coords(1)),1]), "collision_io_initialize_output nf90_put_var stage 1" ) + call netcdf_check( nf90_put_var(nc%id, nc%stage_varid, nc%stage_coords(2), start=[1,2], count=[len(nc%stage_coords(2)),1]), "collision_io_initialize_output nf90_put_var stage 2" ) end associate end select @@ -194,70 +195,73 @@ module subroutine collision_io_initialize_output(self, param) end subroutine collision_io_initialize_output - module subroutine collision_io_write_frame_snapshot(self, nc, param) + module subroutine collision_io_write_frame_snapshot(self, history, param) !! author: David A. Minton !! !! Write a frame of output of a collision result use netcdf implicit none ! Arguments - class(collision_snapshot), intent(in) :: self !! Swiftest encounter structure - class(netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular encounter io NetCDF dataset - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(collision_snapshot), intent(in) :: self !! Swiftest encounter structure + class(encounter_storage(*)), intent(inout) :: history !! Collision history object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters ! Internals integer(I4B) :: i, idslot, old_mode, npl, stage character(len=:), allocatable :: charstring class(swiftest_pl), allocatable :: pl - select type(nc) + select type(nc => history%nc) class is (collision_io_parameters) - select type (param) - class is (symba_parameters) - associate(system => self%collision_system, impactors => self%collision_system%impactors, fragments => self%collision_system%fragments, collision_history => param%collision_history, eslot => param%ioutput) - call check( nf90_set_fill(nc%id, nf90_nofill, old_mode), "collision_io_write_frame_snapshot nf90_set_fill" ) + associate(system => self%collision_system, impactors => self%collision_system%impactors, fragments => self%collision_system%fragments, eslot => param%ioutput) + call netcdf_check( nf90_set_fill(nc%id, nf90_nofill, old_mode), "collision_io_write_frame_snapshot nf90_set_fill" ) - call check( nf90_put_var(nc%id, nc%time_varid, self%t, start=[eslot]), "collision_io_write_frame_snapshot nf90_put_var time_varid" ) - call check( nf90_put_var(nc%id, nc%loop_varid, int(self%iloop,kind=I4B), start=[eslot]), "collision_io_write_frame_snapshot nf90_put_varloop_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%time_varid, self%t, start=[eslot]), "collision_io_write_frame_snapshot nf90_put_var time_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%loop_varid, int(self%iloop,kind=I4B), start=[eslot]), "collision_io_write_frame_snapshot nf90_put_varloop_varid" ) - charstring = trim(adjustl(REGIME_NAMES(impactors%regime))) - call check( nf90_put_var(nc%id, nc%regime_varid, charstring, start=[1, eslot], count=[len(charstring), 1]), "collision_io_write_frame_snapshot nf90_put_var regime_varid" ) - call check( nf90_put_var(nc%id, nc%Qloss_varid, impactors%Qloss, start=[eslot] ), "collision_io_write_frame_snapshot nf90_put_var Qloss_varid" ) + charstring = trim(adjustl(REGIME_NAMES(impactors%regime))) + call netcdf_check( nf90_put_var(nc%id, nc%regime_varid, charstring, start=[1, eslot], count=[len(charstring), 1]), "collision_io_write_frame_snapshot nf90_put_var regime_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%Qloss_varid, impactors%Qloss, start=[eslot] ), "collision_io_write_frame_snapshot nf90_put_var Qloss_varid" ) + select type(before =>self%collision_system%before) + class is (swiftest_nbody_system) + select type(after =>self%collision_system%before) + class is (swiftest_nbody_system) do stage = 1,2 if (allocated(pl)) deallocate(pl) select case(stage) case(1) - allocate(pl, source=self%collision_system%before%pl) + allocate(pl, source=before%pl) case(2) - allocate(pl, source=self%collision_system%after%pl) + allocate(pl, source=after%pl) end select npl = pl%nbody do i = 1, npl - idslot = findloc(collision_history%idvals,pl%id(i),dim=1) - call check( nf90_put_var(nc%id, nc%id_varid, pl%id(i), start=[ idslot ]), "collision_io_write_frame_snapshot nf90_put_var id_varid" ) + idslot = findloc(history%idvals,pl%id(i),dim=1) + call netcdf_check( nf90_put_var(nc%id, nc%id_varid, pl%id(i), start=[ idslot ]), "collision_io_write_frame_snapshot nf90_put_var id_varid" ) charstring = trim(adjustl(pl%info(i)%name)) - call check( nf90_put_var(nc%id, nc%name_varid, charstring, start=[1, idslot ], count=[len(charstring), 1]), "collision_io_write_frame_snapshot nf90_put_var name_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%name_varid, charstring, start=[1, idslot ], count=[len(charstring), 1]), "collision_io_write_frame_snapshot nf90_put_var name_varid" ) charstring = trim(adjustl(pl%info(i)%particle_type)) - call check( nf90_put_var(nc%id, nc%ptype_varid, charstring, start=[1, idslot, stage, eslot], count=[len(charstring), 1, 1]), "collision_io_write_frame_snapshot nf90_put_var particle_type_varid" ) - call check( nf90_put_var(nc%id, nc%rh_varid, pl%rh(:,i), start=[1, idslot, stage, eslot], count=[NDIM,1,1,1]), "collision_io_write_frame_snapshot nf90_put_var rh_varid" ) - call check( nf90_put_var(nc%id, nc%vh_varid, pl%vh(:,i), start=[1, idslot, stage, eslot], count=[NDIM,1,1,1]), "collision_io_write_frame_snapshot nf90_put_var vh_varid" ) - call check( nf90_put_var(nc%id, nc%Gmass_varid, pl%Gmass(i), start=[ idslot, stage, eslot]), "collision_io_write_frame_snapshot nf90_put_var Gmass_varid" ) - call check( nf90_put_var(nc%id, nc%radius_varid, pl%radius(i), start=[ idslot, stage, eslot]), "collision_io_write_frame_snapshot nf90_put_var radius_varid" ) - call check( nf90_put_var(nc%id, nc%Ip_varid, pl%Ip(:,i), start=[1, idslot, stage, eslot], count=[NDIM,1,1,1]), "collision_io_write_frame_snapshot nf90_put_var Ip_varid" ) - call check( nf90_put_var(nc%id, nc%rot_varid, pl%rot(:,i), start=[1, idslot, stage, eslot], count=[NDIM,1,1,1]), "collision_io_write_frame_snapshot nf90_put_var rotx_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%ptype_varid, charstring, start=[1, idslot, stage, eslot], count=[len(charstring), 1, 1]), "collision_io_write_frame_snapshot nf90_put_var particle_type_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%rh_varid, pl%rh(:,i), start=[1, idslot, stage, eslot], count=[NDIM,1,1,1]), "collision_io_write_frame_snapshot nf90_put_var rh_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%vh_varid, pl%vh(:,i), start=[1, idslot, stage, eslot], count=[NDIM,1,1,1]), "collision_io_write_frame_snapshot nf90_put_var vh_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%Gmass_varid, pl%Gmass(i), start=[ idslot, stage, eslot]), "collision_io_write_frame_snapshot nf90_put_var Gmass_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%radius_varid, pl%radius(i), start=[ idslot, stage, eslot]), "collision_io_write_frame_snapshot nf90_put_var radius_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%Ip_varid, pl%Ip(:,i), start=[1, idslot, stage, eslot], count=[NDIM,1,1,1]), "collision_io_write_frame_snapshot nf90_put_var Ip_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%rot_varid, pl%rot(:,i), start=[1, idslot, stage, eslot], count=[NDIM,1,1,1]), "collision_io_write_frame_snapshot nf90_put_var rotx_varid" ) end do end do - if (param%lenergy) then - call check( nf90_put_var(nc%id, nc%ke_orb_varid, system%ke_orbit(:), start=[ 1, eslot], count=[ 2, 1]), "collision_io_write_frame_snapshot nf90_put_var ke_orb_varid before" ) - call check( nf90_put_var(nc%id, nc%ke_spin_varid, system%ke_spin(:), start=[ 1, eslot], count=[ 2, 1]), "collision_io_write_frame_snapshot nf90_put_var ke_spin_varid before" ) - call check( nf90_put_var(nc%id, nc%pe_varid, system%pe(:), start=[ 1, eslot], count=[ 2, 1]), "collision_io_write_frame_snapshot nf90_put_var pe_varid before" ) - call check( nf90_put_var(nc%id, nc%L_orb_varid, system%Lorbit(:,:), start=[1, 1, eslot], count=[NDIM, 2, 1]), "collision_io_write_frame_snapshot nf90_put_var L_orb_varid before" ) - call check( nf90_put_var(nc%id, nc%Lspin_varid, system%Lspin(:,:), start=[1, 1, eslot], count=[NDIM, 2, 1]), "collision_io_write_frame_snapshot nf90_put_var Lspin_varid before" ) - end if - - call check( nf90_set_fill(nc%id, old_mode, old_mode) ) - end associate - end select + end select + end select + if (param%lenergy) then + call netcdf_check( nf90_put_var(nc%id, nc%ke_orb_varid, system%ke_orbit(:), start=[ 1, eslot], count=[ 2, 1]), "collision_io_write_frame_snapshot nf90_put_var ke_orb_varid before" ) + call netcdf_check( nf90_put_var(nc%id, nc%ke_spin_varid, system%ke_spin(:), start=[ 1, eslot], count=[ 2, 1]), "collision_io_write_frame_snapshot nf90_put_var ke_spin_varid before" ) + call netcdf_check( nf90_put_var(nc%id, nc%pe_varid, system%pe(:), start=[ 1, eslot], count=[ 2, 1]), "collision_io_write_frame_snapshot nf90_put_var pe_varid before" ) + call netcdf_check( nf90_put_var(nc%id, nc%L_orb_varid, system%Lorbit(:,:), start=[1, 1, eslot], count=[NDIM, 2, 1]), "collision_io_write_frame_snapshot nf90_put_var L_orb_varid before" ) + call netcdf_check( nf90_put_var(nc%id, nc%Lspin_varid, system%Lspin(:,:), start=[1, 1, eslot], count=[NDIM, 2, 1]), "collision_io_write_frame_snapshot nf90_put_var Lspin_varid before" ) + end if + + call netcdf_check( nf90_set_fill(nc%id, old_mode, old_mode) ) + end associate end select return end subroutine collision_io_write_frame_snapshot diff --git a/src/collision/collision_regime.f90 b/src/collision/collision_regime.f90 index 94079e388..b74d76d5f 100644 --- a/src/collision/collision_regime.f90 +++ b/src/collision/collision_regime.f90 @@ -7,86 +7,11 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(collision_classes) s_collision_regime +submodule(collision) s_collision_regime use swiftest contains - module subroutine collision_regime_impactors(self, system, param) - !! Author: Jennifer L.L. Pouplin, Carlisle A. Wishard, and David A. Minton - !! - !! Determine which fragmentation regime the set of impactors will be. This subroutine is a wrapper for the non-polymorphic raggle_regime_collresolve subroutine. - !! It converts to SI units prior to calling - implicit none - ! Arguments - class(collision_impactors), intent(inout) :: self !! Collision system impactors object - class(swiftest_nbody_system), intent(in) :: system !! Swiftest nbody system object - class(swiftest_parameters), intent(in) :: param !! Current Swiftest run configuration parameters - ! Internals - integer(I4B) :: jtarg, jproj - real(DP), dimension(2) :: radius_si, mass_si, density_si - real(DP) :: min_mfrag_si, Mcb_si - real(DP), dimension(NDIM) :: x1_si, v1_si, x2_si, v2_si, runit - real(DP) :: mlr, mslr, mtot, dentot - - associate(impactors => self) - ! Convert all quantities to SI units and determine which of the pair is the projectile vs. target before sending them to the regime determination subroutine - if (impactors%mass(1) > impactors%mass(2)) then - jtarg = 1 - jproj = 2 - else - jtarg = 2 - jproj = 1 - end if - mass_si(:) = impactors%mass([jtarg, jproj]) * param%MU2KG !! The two-body equivalent masses of the collider system - radius_si(:) = impactors%radius([jtarg, jproj]) * param%DU2M !! The two-body equivalent radii of the collider system - density_si(:) = mass_si(:) / (4.0_DP / 3._DP * PI * radius_si(:)**3) !! The two-body equivalent density of the collider system - x1_si(:) = impactors%rb(:,jtarg) * param%DU2M !! The first body of the two-body equivalent position vector the collider system - v1_si(:) = impactors%vb(:,jtarg) * param%DU2M / param%TU2S !! The first body of the two-body equivalent velocity vector the collider system - x2_si(:) = impactors%rb(:,jproj) * param%DU2M !! The second body of the two-body equivalent position vector the collider system - v2_si(:) = impactors%vb(:,jproj) * param%DU2M / param%TU2S !! The second body of the two-body equivalent velocity vector the collider system - Mcb_si = system%cb%mass * param%MU2KG !! The central body mass of the system - select type(param) - class is (symba_parameters) - min_mfrag_si = (param%min_GMfrag / param%GU) * param%MU2KG !! The minimum fragment mass to generate. Collider systems that would otherwise generate less massive fragments than this value will be forced to merge instead - class default - min_mfrag_si = 0.0_DP - end select - - mtot = sum(mass_si(:)) - dentot = sum(mass_si(:) * density_si(:)) / mtot - - !! Use the positions and velocities of the parents from indside the step (at collision) to calculate the collisional regime - call collision_regime_collresolve(Mcb_si, mass_si(jtarg), mass_si(jproj), radius_si(jtarg), radius_si(jproj), & - x1_si(:), x2_si(:), v1_si(:), v2_si(:), density_si(jtarg), density_si(jproj), & - min_mfrag_si, impactors%regime, mlr, mslr, impactors%Qloss) - - if (allocated(impactors%mass_dist)) deallocate(impactors%mass_dist) - allocate(impactors%mass_dist(3)) - impactors%mass_dist(1) = min(max(mlr, 0.0_DP), mtot) - impactors%mass_dist(2) = min(max(mslr, 0.0_DP), mtot) - impactors%mass_dist(3) = min(max(mtot - mlr - mslr, 0.0_DP), mtot) - - ! Find the center of mass of the collisional system - mtot = sum(impactors%mass(:)) - impactors%rbcom(:) = (impactors%mass(1) * impactors%rb(:,1) + impactors%mass(2) * impactors%rb(:,2)) / mtot - impactors%vbcom(:) = (impactors%mass(1) * impactors%vb(:,1) + impactors%mass(2) * impactors%vb(:,2)) / mtot - - ! Find the point of impact between the two bodies - runit(:) = impactors%rb(:,2) - impactors%rb(:,1) - runit(:) = runit(:) / (.mag. runit(:)) - impactors%rbimp(:) = impactors%rb(:,1) + impactors%radius(1) * runit(:) - - ! Convert quantities back to the system units and save them into the fragment system - impactors%mass_dist(:) = (impactors%mass_dist(:) / param%MU2KG) - impactors%Qloss = impactors%Qloss * (param%TU2S / param%DU2M)**2 / param%MU2KG - - !call fraggle_io_log_regime(impactors, fragments) - end associate - - return - end subroutine collision_regime_impactors - subroutine collision_regime_collresolve(Mcb, m1, m2, rad1, rad2, rh1, rh2, vb1, vb2, den1, den2, min_mfrag, & regime, Mlr, Mslr, Qloss) @@ -198,7 +123,7 @@ subroutine collision_regime_collresolve(Mcb, m1, m2, rad1, rad2, rh1, rh2, vb1, Mlr = Mtot Mslr = 0.0_DP Qloss = 0.0_DP - call io_log_one_message(FRAGGLE_LOG_OUT, & + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, & "Fragments would have mass below the minimum. Converting this collision into a merger.") else if( Vimp < Vescp) then @@ -382,4 +307,87 @@ end function calc_c_star end subroutine collision_regime_collresolve + + module subroutine collision_regime_impactors(self, system, param) + !! Author: Jennifer L.L. Pouplin, Carlisle A. Wishard, and David A. Minton + !! + !! Determine which fragmentation regime the set of impactors will be. This subroutine is a wrapper for the non-polymorphic raggle_regime_collresolve subroutine. + !! It converts to SI units prior to calling + implicit none + ! Arguments + class(collision_impactors), intent(inout) :: self !! Collision system impactors object + class(base_nbody_system), intent(in) :: system !! Swiftest nbody system object + class(base_parameters), intent(in) :: param !! Current Swiftest run configuration parameters + ! Internals + integer(I4B) :: jtarg, jproj + real(DP), dimension(2) :: radius_si, mass_si, density_si + real(DP) :: min_mfrag_si, Mcb_si + real(DP), dimension(NDIM) :: x1_si, v1_si, x2_si, v2_si, runit + real(DP) :: mlr, mslr, mtot, dentot + + associate(impactors => self) + select type (system) + class is (swiftest_nbody_system) + ! Convert all quantities to SI units and determine which of the pair is the projectile vs. target before sending them to the regime determination subroutine + if (impactors%mass(1) > impactors%mass(2)) then + jtarg = 1 + jproj = 2 + else + jtarg = 2 + jproj = 1 + end if + mass_si(:) = impactors%mass([jtarg, jproj]) * param%MU2KG !! The two-body equivalent masses of the collider system + radius_si(:) = impactors%radius([jtarg, jproj]) * param%DU2M !! The two-body equivalent radii of the collider system + density_si(:) = mass_si(:) / (4.0_DP / 3._DP * PI * radius_si(:)**3) !! The two-body equivalent density of the collider system + x1_si(:) = impactors%rb(:,jtarg) * param%DU2M !! The first body of the two-body equivalent position vector the collider system + v1_si(:) = impactors%vb(:,jtarg) * param%DU2M / param%TU2S !! The first body of the two-body equivalent velocity vector the collider system + x2_si(:) = impactors%rb(:,jproj) * param%DU2M !! The second body of the two-body equivalent position vector the collider system + v2_si(:) = impactors%vb(:,jproj) * param%DU2M / param%TU2S !! The second body of the two-body equivalent velocity vector the collider system + Mcb_si = system%cb%mass * param%MU2KG !! The central body mass of the system + select type(param) + class is (base_parameters) + min_mfrag_si = (param%min_GMfrag / param%GU) * param%MU2KG !! The minimum fragment mass to generate. Collider systems that would otherwise generate less massive fragments than this value will be forced to merge instead + class default + min_mfrag_si = 0.0_DP + end select + + mtot = sum(mass_si(:)) + dentot = sum(mass_si(:) * density_si(:)) / mtot + + !! Use the positions and velocities of the parents from indside the step (at collision) to calculate the collisional regime + call collision_regime_collresolve(Mcb_si, mass_si(jtarg), mass_si(jproj), radius_si(jtarg), radius_si(jproj), & + x1_si(:), x2_si(:), v1_si(:), v2_si(:), density_si(jtarg), density_si(jproj), & + min_mfrag_si, impactors%regime, mlr, mslr, impactors%Qloss) + + if (allocated(impactors%mass_dist)) deallocate(impactors%mass_dist) + allocate(impactors%mass_dist(3)) + impactors%mass_dist(1) = min(max(mlr, 0.0_DP), mtot) + impactors%mass_dist(2) = min(max(mslr, 0.0_DP), mtot) + impactors%mass_dist(3) = min(max(mtot - mlr - mslr, 0.0_DP), mtot) + + ! Find the center of mass of the collisional system + mtot = sum(impactors%mass(:)) + impactors%rbcom(:) = (impactors%mass(1) * impactors%rb(:,1) + impactors%mass(2) * impactors%rb(:,2)) / mtot + impactors%vbcom(:) = (impactors%mass(1) * impactors%vb(:,1) + impactors%mass(2) * impactors%vb(:,2)) / mtot + + ! Find the point of impact between the two bodies + runit(:) = impactors%rb(:,2) - impactors%rb(:,1) + runit(:) = runit(:) / (.mag. runit(:)) + impactors%rbimp(:) = impactors%rb(:,1) + impactors%radius(1) * runit(:) + + ! Convert quantities back to the system units and save them into the fragment system + impactors%mass_dist(:) = (impactors%mass_dist(:) / param%MU2KG) + impactors%Qloss = impactors%Qloss * (param%TU2S / param%DU2M)**2 / param%MU2KG + + !call fraggle_io_log_regime(impactors, fragments) + end select + end associate + + return + end subroutine collision_regime_impactors + + ! module subroutine collision_regime_resolve(self) + ! end subroutine collision_regime_resolve + + end submodule s_collision_regime \ No newline at end of file diff --git a/src/collision/collision_resolve.f90 b/src/collision/collision_resolve.f90 new file mode 100644 index 000000000..4ac8bdf16 --- /dev/null +++ b/src/collision/collision_resolve.f90 @@ -0,0 +1,768 @@ +!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh +!! This file is part of Swiftest. +!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License +!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. +!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty +!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. +!! You should have received a copy of the GNU General Public License along with Swiftest. +!! If not, see: https://www.gnu.org/licenses. + +submodule (collision) s_collision_resolve + use swiftest +contains + + module function collision_resolve_merge(system, param, t) result(status) + !! author: Jennifer L.L. Pouplin, Carlisle A. Wishard, and David A. Minton + !! + !! Merge massive bodies. + !! + !! Adapted from David E. Kaufmann's Swifter routines swiftest_merge_pl.f90 and swiftest_discard_merge_pl.f90 + !! + !! Adapted from Hal Levison's Swift routines symba5_merge.f and discard_mass_merge.f + implicit none + ! Arguments + class(base_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters with Swiftest additions + real(DP), intent(in) :: t !! Time of collision + ! Result + integer(I4B) :: status !! Status flag assigned to this outcome + ! Internals + integer(I4B) :: i, j, k, ibiggest + real(DP), dimension(NDIM) :: Lspin_new + real(DP) :: dpe + character(len=STRMAX) :: message + + select type(system) + class is (swiftest_nbody_system) + associate(collision_system => system%collision_system, impactors => system%collision_system%impactors, fragments => system%collision_system%fragments) + message = "Merging" + call collision_resolve_collider_message(system%pl, impactors%id, message) + ! call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, message) + + select type(pl => system%pl) + class is (swiftest_pl) + + call collision_system%set_mass_dist(param) + + ! Calculate the initial energy of the system without the collisional family + call collision_system%get_energy_and_momentum(system, param, lbefore=.true.) + + ibiggest = impactors%id(maxloc(pl%Gmass(impactors%id(:)), dim=1)) + fragments%id(1) = pl%id(ibiggest) + fragments%rb(:,1) = impactors%rbcom(:) + fragments%vb(:,1) = impactors%vbcom(:) + + if (param%lrotation) then + ! Conserve angular momentum by putting pre-impact orbital momentum into spin of the new body + Lspin_new(:) = impactors%Lorbit(:,1) + impactors%Lorbit(:,2) + impactors%Lspin(:,1) + impactors%Lspin(:,2) + + ! Assume prinicpal axis rotation on 3rd Ip axis + fragments%rot(:,1) = Lspin_new(:) / (fragments%Ip(3,1) * fragments%mass(1) * fragments%radius(1)**2) + else ! If spin is not enabled, we will consider the lost pre-collision angular momentum as "escaped" and add it to our bookkeeping variable + system%Lescape(:) = system%Lescape(:) + impactors%Lorbit(:,1) + impactors%Lorbit(:,2) + end if + + ! Keep track of the component of potential energy due to the pre-impact impactors%id for book-keeping + ! Get the energy of the system after the collision + call collision_system%get_energy_and_momentum(system, param, lbefore=.false.) + dpe = collision_system%pe(2) - collision_system%pe(1) + system%Ecollisions = system%Ecollisions - dpe + system%Euntracked = system%Euntracked + dpe + + + ! Update any encounter lists that have the removed bodies in them so that they instead point to the new + do k = 1, system%plpl_encounter%nenc + do j = 1, impactors%ncoll + i = impactors%id(j) + if (i == ibiggest) cycle + if (system%plpl_encounter%id1(k) == pl%id(i)) then + system%plpl_encounter%id1(k) = pl%id(ibiggest) + system%plpl_encounter%index1(k) = i + end if + if (system%plpl_encounter%id2(k) == pl%id(i)) then + system%plpl_encounter%id2(k) = pl%id(ibiggest) + system%plpl_encounter%index2(k) = i + end if + if (system%plpl_encounter%id1(k) == system%plpl_encounter%id2(k)) system%plpl_encounter%status(k) = INACTIVE + end do + end do + + status = MERGED + + call collision_resolve_mergeaddsub(system, param, t, status) + + end select + end associate + end select + return + end function collision_resolve_merge + + + subroutine collision_resolve_collider_message(pl, collidx, collider_message) + !! author: David A. Minton + !! + !! Prints a nicely formatted message about which bodies collided, including their names and ids. + !! This subroutine appends the body names and ids to an input message. + implicit none + ! Arguments + class(swiftest_pl), intent(in) :: pl !! Swiftest massive body object + integer(I4B), dimension(:), intent(in) :: collidx !! Index of collisional impactors%id members + character(*), intent(inout) :: collider_message !! The message to print to the screen. + ! Internals + integer(I4B) :: i, n + character(len=STRMAX) :: idstr + + n = size(collidx) + if (n == 0) return + + do i = 1, n + if (i > 1) collider_message = trim(adjustl(collider_message)) // " and " + collider_message = " " // trim(adjustl(collider_message)) // " " // trim(adjustl(pl%info(collidx(i))%name)) + write(idstr, '(I10)') pl%id(collidx(i)) + collider_message = trim(adjustl(collider_message)) // " (" // trim(adjustl(idstr)) // ") " + end do + + return + end subroutine collision_resolve_collider_message + + + function collision_resolve_consolidate_impactors(pl, cb, param, idx_parent, impactors) result(lflag) + !! author: David A. Minton + !! + !! Loops through the pl-pl collision list and groups families together by index. Outputs the indices of all impactors%id members, + !! and pairs of quantities (x and v vectors, mass, radius, Lspin, and Ip) that can be used to resolve the collisional outcome. + implicit none + ! Arguments + class(swiftest_pl), intent(inout) :: pl !! Swiftest massive body object + class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object + class(base_parameters), intent(in) :: param !! Current run configuration parameters with Swiftest additions + integer(I4B), dimension(2), intent(inout) :: idx_parent !! Index of the two bodies considered the "parents" of the collision + class(collision_impactors), intent(out) :: impactors + ! Result + logical :: lflag !! Logical flag indicating whether a impactors%id was successfully created or not + ! Internals + type collidx_array + integer(I4B), dimension(:), allocatable :: id + integer(I4B), dimension(:), allocatable :: idx + end type collidx_array + type(collidx_array), dimension(2) :: parent_child_index_array + integer(I4B), dimension(2) :: nchild + integer(I4B) :: i, j, nimpactors, idx_child + real(DP), dimension(2) :: volume, density + real(DP) :: mchild, volchild + real(DP), dimension(NDIM) :: xc, vc, xcom, vcom, xchild, vchild, xcrossv + real(DP), dimension(NDIM,2) :: mxc, vcc + + nchild(:) = pl%kin(idx_parent(:))%nchild + ! If all of these bodies share a parent, but this is still a unique collision, move the last child + ! out of the parent's position and make it the secondary body + if (idx_parent(1) == idx_parent(2)) then + if (nchild(1) == 0) then ! There is only one valid body recorded in this pair (this could happen due to restructuring of the kinship relationships, though it should be rare) + lflag = .false. + call pl%reset_kinship([idx_parent(1)]) + return + end if + idx_parent(2) = pl%kin(idx_parent(1))%child(nchild(1)) + nchild(1) = nchild(1) - 1 + nchild(2) = 0 + pl%kin(idx_parent(:))%nchild = nchild(:) + pl%kin(idx_parent(2))%parent = idx_parent(1) + end if + + impactors%mass(:) = pl%mass(idx_parent(:)) ! Note: This is meant to mass, not G*mass, as the collisional regime determination uses mass values that will be converted to Si + impactors%radius(:) = pl%radius(idx_parent(:)) + volume(:) = (4.0_DP / 3.0_DP) * PI * impactors%radius(:)**3 + + ! Group together the ids and indexes of each collisional parent and its children + do j = 1, 2 + allocate(parent_child_index_array(j)%idx(nchild(j)+ 1)) + allocate(parent_child_index_array(j)%id(nchild(j)+ 1)) + associate(idx_arr => parent_child_index_array(j)%idx, & + id_arr => parent_child_index_array(j)%id, & + ncj => nchild(j), & + plkinj => pl%kin(idx_parent(j))) + idx_arr(1) = idx_parent(j) + if (ncj > 0) idx_arr(2:ncj + 1) = plkinj%child(1:ncj) + id_arr(:) = pl%id(idx_arr(:)) + end associate + end do + + ! Consolidate the groups of collsional parents with any children they may have into a single "impactors%id" index array + nimpactors = 2 + sum(nchild(:)) + allocate(impactors%id(nimpactors)) + impactors%id = [parent_child_index_array(1)%idx(:),parent_child_index_array(2)%idx(:)] + + impactors%ncoll = count(pl%lcollision(impactors%id(:))) + impactors%id = pack(impactors%id(:), pl%lcollision(impactors%id(:))) + impactors%Lspin(:,:) = 0.0_DP + impactors%Ip(:,:) = 0.0_DP + + ! Find the barycenter of each body along with its children, if it has any + do j = 1, 2 + impactors%rb(:, j) = pl%rh(:, idx_parent(j)) + cb%rb(:) + impactors%vb(:, j) = pl%vb(:, idx_parent(j)) + ! Assume principal axis rotation about axis corresponding to highest moment of inertia (3rd Ip) + if (param%lrotation) then + impactors%Ip(:, j) = impactors%mass(j) * pl%Ip(:, idx_parent(j)) + impactors%Lspin(:, j) = impactors%Ip(3, j) * impactors%radius(j)**2 * pl%rot(:, idx_parent(j)) + end if + + if (nchild(j) > 0) then + do i = 1, nchild(j) ! Loop over all children and take the mass weighted mean of the properties + idx_child = parent_child_index_array(j)%idx(i + 1) + if (.not. pl%lcollision(idx_child)) cycle + mchild = pl%mass(idx_child) + xchild(:) = pl%rh(:, idx_child) + cb%rb(:) + vchild(:) = pl%vb(:, idx_child) + volchild = (4.0_DP / 3.0_DP) * PI * pl%radius(idx_child)**3 + volume(j) = volume(j) + volchild + ! Get angular momentum of the child-parent pair and add that to the spin + ! Add the child's spin + if (param%lrotation) then + xcom(:) = (impactors%mass(j) * impactors%rb(:,j) + mchild * xchild(:)) / (impactors%mass(j) + mchild) + vcom(:) = (impactors%mass(j) * impactors%vb(:,j) + mchild * vchild(:)) / (impactors%mass(j) + mchild) + xc(:) = impactors%rb(:, j) - xcom(:) + vc(:) = impactors%vb(:, j) - vcom(:) + xcrossv(:) = xc(:) .cross. vc(:) + impactors%Lspin(:, j) = impactors%Lspin(:, j) + impactors%mass(j) * xcrossv(:) + + xc(:) = xchild(:) - xcom(:) + vc(:) = vchild(:) - vcom(:) + xcrossv(:) = xc(:) .cross. vc(:) + impactors%Lspin(:, j) = impactors%Lspin(:, j) + mchild * xcrossv(:) + + impactors%Lspin(:, j) = impactors%Lspin(:, j) + mchild * pl%Ip(3, idx_child) & + * pl%radius(idx_child)**2 & + * pl%rot(:, idx_child) + impactors%Ip(:, j) = impactors%Ip(:, j) + mchild * pl%Ip(:, idx_child) + end if + + ! Merge the child and parent + impactors%mass(j) = impactors%mass(j) + mchild + impactors%rb(:, j) = xcom(:) + impactors%vb(:, j) = vcom(:) + end do + end if + density(j) = impactors%mass(j) / volume(j) + impactors%radius(j) = (3 * volume(j) / (4 * PI))**(1.0_DP / 3.0_DP) + if (param%lrotation) impactors%Ip(:, j) = impactors%Ip(:, j) / impactors%mass(j) + end do + lflag = .true. + + xcom(:) = (impactors%mass(1) * impactors%rb(:, 1) + impactors%mass(2) * impactors%rb(:, 2)) / sum(impactors%mass(:)) + vcom(:) = (impactors%mass(1) * impactors%vb(:, 1) + impactors%mass(2) * impactors%vb(:, 2)) / sum(impactors%mass(:)) + mxc(:, 1) = impactors%mass(1) * (impactors%rb(:, 1) - xcom(:)) + mxc(:, 2) = impactors%mass(2) * (impactors%rb(:, 2) - xcom(:)) + vcc(:, 1) = impactors%vb(:, 1) - vcom(:) + vcc(:, 2) = impactors%vb(:, 2) - vcom(:) + impactors%Lorbit(:,:) = mxc(:,:) .cross. vcc(:,:) + + ! Destroy the kinship relationships for all members of this impactors%id + call pl%reset_kinship(impactors%id(:)) + + return + end function collision_resolve_consolidate_impactors + + + module subroutine collision_resolve_extract_plpl(self, system, param) + !! author: David A. Minton + !! + !! Processes the pl-pl encounter list remove only those encounters that led to a collision + !! + implicit none + ! Arguments + class(collision_list_plpl), intent(inout) :: self !! pl-pl encounter list + class(base_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(base_parameters), intent(in) :: param !! Current run configuration parameters + ! Internals + logical, dimension(:), allocatable :: lplpl_collision + 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, nplplenc + + select type(system) + class is (swiftest_nbody_system) + select type (pl => system%pl) + class is (swiftest_pl) + associate(plpl_encounter => self, idx1 => self%index1, idx2 => self%index2, plparent => pl%kin%parent) + nplplenc = plpl_encounter%nenc + allocate(lplpl_collision(nplplenc)) + lplpl_collision(:) = plpl_encounter%status(1:nplplenc) == COLLIDED + if (.not.any(lplpl_collision)) return + ! Collisions have been detected in this step. So we need to determine which of them are between unique bodies. + + ! Get the subset of pl-pl encounters that lead to a collision + ncollisions = count(lplpl_collision(:)) + allocate(collision_idx(ncollisions)) + collision_idx = pack([(i, i=1, nplplenc)], lplpl_collision) + + ! Get the subset of collisions that involve a unique pair of parents + allocate(lplpl_unique_parent(ncollisions)) + + lplpl_unique_parent(:) = plparent(idx1(collision_idx(:))) /= plparent(idx2(collision_idx(:))) + nunique_parent = count(lplpl_unique_parent(:)) + allocate(unique_parent_idx(nunique_parent)) + unique_parent_idx = pack(collision_idx(:), lplpl_unique_parent(:)) + + ! Scrub all pl-pl collisions involving unique pairs of parents, which will remove all duplicates and leave behind + ! all pairs that have themselves as parents but are not part of the unique parent list. This can hapepn in rare cases + ! due to restructuring of parent/child relationships when there are large numbers of multi-body collisions in a single + ! step + lplpl_unique_parent(:) = .true. + do index_coll = 1, ncollisions + associate(ip1 => plparent(idx1(collision_idx(index_coll))), ip2 => plparent(idx2(collision_idx(index_coll)))) + lplpl_unique_parent(:) = .not. ( any(plparent(idx1(unique_parent_idx(:))) == ip1) .or. & + any(plparent(idx2(unique_parent_idx(:))) == ip1) .or. & + any(plparent(idx1(unique_parent_idx(:))) == ip2) .or. & + any(plparent(idx2(unique_parent_idx(:))) == ip2) ) + end associate + end do + + ! Reassemble collision index list to include only those containing the unique pairs of parents, plus all the non-unique pairs that don't + ! contain a parent body on the unique parent list. + ncollisions = nunique_parent + count(lplpl_unique_parent) + collision_idx = [unique_parent_idx(:), pack(collision_idx(:), lplpl_unique_parent(:))] + + ! Create a mask that contains only the pl-pl encounters that did not result in a collision, and then discard them + lplpl_collision(:) = .false. + lplpl_collision(collision_idx(:)) = .true. + call plpl_encounter%spill(system%plpl_collision, lplpl_collision, ldestructive=.true.) ! Extract any encounters that are not collisions from the list. + end associate + end select + end select + + return + end subroutine collision_resolve_extract_plpl + + module subroutine collision_resolve_extract_pltp(self, system, param) + implicit none + class(collision_list_pltp), intent(inout) :: self !! pl-tp encounter list + class(base_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(base_parameters), intent(in) :: param !! Current run configuration parameters + + return + end subroutine collision_resolve_extract_pltp + + + module subroutine collision_resolve_make_impactors_pl(pl, idx) + !! author: Jennifer L.L. Pouplin, Carlisle A. wishard, and David A. Minton + !! + !! When a single body is involved in more than one collision in a single step, it becomes part of a impactors%id. + !! The largest body involved in a multi-body collision is the "parent" and all bodies that collide with it are its "children," + !! including those that collide with the children. + !! + !! Adapted from David E. Kaufmann's Swifter routine swiftest_merge_pl.f90 + !! + !! Adapted from Hal Levison's Swift routine symba5_merge.f + implicit none + ! Arguments + class(base_object), intent(inout) :: pl !! Swiftest massive body object + integer(I4B), dimension(:), intent(in) :: idx !! Array holding the indices of the two bodies involved in the collision + ! Internals + integer(I4B) :: i, j, index_parent, index_child, p1, p2 + integer(I4B) :: nchild_inherit, nchild_orig, nchild_new + integer(I4B), dimension(:), allocatable :: temp + + select type(pl) + class is (swiftest_pl) + + p1 = pl%kin(idx(1))%parent + p2 = pl%kin(idx(2))%parent + if (p1 == p2) return ! This is a collision between to children of a shared parent. We will ignore it. + + if (pl%mass(p1) > pl%mass(p2)) then + index_parent = p1 + index_child = p2 + else + index_parent = p2 + index_child = p1 + end if + + ! Expand the child array (or create it if necessary) and copy over the previous lists of children + nchild_orig = pl%kin(index_parent)%nchild + nchild_inherit = pl%kin(index_child)%nchild + nchild_new = nchild_orig + nchild_inherit + 1 + allocate(temp(nchild_new)) + + if (nchild_orig > 0) temp(1:nchild_orig) = pl%kin(index_parent)%child(1:nchild_orig) + ! Find out if the child body has any children of its own. The new parent wil inherit these children + if (nchild_inherit > 0) then + temp(nchild_orig+1:nchild_orig+nchild_inherit) = pl%kin(index_child)%child(1:nchild_inherit) + do i = 1, nchild_inherit + j = pl%kin(index_child)%child(i) + ! Set the childrens' parent to the new parent + pl%kin(j)%parent = index_parent + end do + end if + call pl%reset_kinship([index_child]) + ! Add the new child to its parent + pl%kin(index_child)%parent = index_parent + temp(nchild_new) = index_child + ! Save the new child array to the parent + pl%kin(index_parent)%nchild = nchild_new + call move_alloc(from=temp, to=pl%kin(index_parent)%child) + end select + + return + end subroutine collision_resolve_make_impactors_pl + + + subroutine collision_resolve_mergeaddsub(system, param, t, status) + !! author: David A. Minton + !! + !! Fills the pl_discards and pl_adds with removed and added bodies + !! + use symba, only : symba_pl + implicit none + ! Arguments + class(base_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters with Swiftest additions + real(DP), intent(in) :: t !! Time of collision + integer(I4B), intent(in) :: status !! Status flag to assign to adds + ! Internals + integer(I4B) :: i, ibiggest, ismallest, iother, nstart, nend, nimpactors, nfrag + logical, dimension(:), allocatable :: lmask + class(swiftest_pl), allocatable :: plnew, plsub + character(*), parameter :: FRAGFMT = '("Newbody",I0.7)' + character(len=NAMELEN) :: newname, origin_type + + select type(system) + class is (swiftest_nbody_system) + select type(param) + class is (swiftest_parameters) + associate(pl => system%pl, pl_discards => system%pl_discards, info => system%pl%info, pl_adds => system%pl_adds, cb => system%cb, npl => pl%nbody, & + collision_system => system%collision_system, impactors => system%collision_system%impactors,fragments => system%collision_system%fragments) + + ! Add the impactors%id bodies to the subtraction list + nimpactors = impactors%ncoll + nfrag = fragments%nbody + + param%maxid_collision = max(param%maxid_collision, maxval(system%pl%info(:)%collision_id)) + param%maxid_collision = param%maxid_collision + 1 + + ! Setup new bodies + allocate(plnew, mold=pl) + call plnew%setup(nfrag, param) + ibiggest = impactors%id(maxloc(pl%Gmass(impactors%id(:)), dim=1)) + ismallest = impactors%id(minloc(pl%Gmass(impactors%id(:)), dim=1)) + + ! Copy over identification, information, and physical properties of the new bodies from the fragment list + plnew%id(1:nfrag) = fragments%id(1:nfrag) + plnew%rb(:, 1:nfrag) = fragments%rb(:, 1:nfrag) + plnew%vb(:, 1:nfrag) = fragments%vb(:, 1:nfrag) + call pl%vb2vh(cb) + call pl%rh2rb(cb) + do i = 1, nfrag + plnew%rh(:,i) = fragments%rb(:, i) - cb%rb(:) + plnew%vh(:,i) = fragments%vb(:, i) - cb%vb(:) + end do + plnew%mass(1:nfrag) = fragments%mass(1:nfrag) + plnew%Gmass(1:nfrag) = param%GU * fragments%mass(1:nfrag) + plnew%radius(1:nfrag) = fragments%radius(1:nfrag) + plnew%density(1:nfrag) = fragments%mass(1:nfrag) / fragments%radius(1:nfrag) + call plnew%set_rhill(cb) + + select case(status) + case(SUPERCATASTROPHIC) + plnew%status(1:nfrag) = NEW_PARTICLE + do i = 1, nfrag + write(newname, FRAGFMT) fragments%id(i) + call plnew%info(i)%set_value(origin_type="Supercatastrophic", origin_time=t, name=newname, & + origin_rh=plnew%rh(:,i), origin_vh=plnew%vh(:,i), & + collision_id=param%maxid_collision) + end do + do i = 1, nimpactors + if (impactors%id(i) == ibiggest) then + iother = ismallest + else + iother = ibiggest + end if + call pl%info(impactors%id(i))%set_value(status="Supercatastrophic", discard_time=t, & + discard_rh=pl%rh(:,i), discard_vh=pl%vh(:,i), & + discard_body_id=iother) + end do + case(DISRUPTED,HIT_AND_RUN_DISRUPT) + if (status == DISRUPTED) then + write(origin_type,*) "Disruption" + else if (status == HIT_AND_RUN_DISRUPT) then + write(origin_type,*) "Hit and run fragmention" + end if + call plnew%info(1)%copy(pl%info(ibiggest)) + plnew%status(1) = OLD_PARTICLE + do i = 2, nfrag + write(newname, FRAGFMT) fragments%id(i) + call plnew%info(i)%set_value(origin_type=origin_type, origin_time=t, name=newname, & + origin_rh=plnew%rh(:,i), origin_vh=plnew%vh(:,i), & + collision_id=param%maxid_collision) + end do + do i = 1, nimpactors + if (impactors%id(i) == ibiggest) cycle + iother = ibiggest + call pl%info(impactors%id(i))%set_value(status=origin_type, discard_time=t, & + discard_rh=pl%rh(:,i), discard_vh=pl%vh(:,i), & + discard_body_id=iother) + end do + case(MERGED) + call plnew%info(1)%copy(pl%info(ibiggest)) + plnew%status(1) = OLD_PARTICLE + do i = 1, nimpactors + if (impactors%id(i) == ibiggest) cycle + + iother = ibiggest + call pl%info(impactors%id(i))%set_value(status="MERGED", discard_time=t, discard_rh=pl%rh(:,i), & + discard_vh=pl%vh(:,i), discard_body_id=iother) + end do + end select + + if (param%lrotation) then + plnew%Ip(:, 1:nfrag) = fragments%Ip(:, 1:nfrag) + plnew%rot(:, 1:nfrag) = fragments%rot(:, 1:nfrag) + end if + + ! if (param%ltides) then + ! plnew%Q = pl%Q(ibiggest) + ! plnew%k2 = pl%k2(ibiggest) + ! plnew%tlag = pl%tlag(ibiggest) + ! end if + + !Copy over or set integration parameters for new bodies + plnew%lcollision(1:nfrag) = .false. + plnew%ldiscard(1:nfrag) = .false. + select type(pl) + class is (symba_pl) + select type(plnew) + class is (symba_pl) + plnew%levelg(1:nfrag) = pl%levelg(ibiggest) + plnew%levelm(1:nfrag) = pl%levelm(ibiggest) + end select + end select + + plnew%lmtiny(1:nfrag) = plnew%Gmass(1:nfrag) < param%GMTINY + where(plnew%lmtiny(1:nfrag)) + plnew%info(1:nfrag)%particle_type = PL_TINY_TYPE_NAME + elsewhere + plnew%info(1:nfrag)%particle_type = PL_TYPE_NAME + end where + + ! Log the properties of the new bodies + select type(after => collision_system%after) + class is (swiftest_nbody_system) + allocate(after%pl, source=plnew) + end select + + ! Append the new merged body to the list + nstart = pl_adds%nbody + 1 + nend = pl_adds%nbody + nfrag + call pl_adds%append(plnew, lsource_mask=[(.true., i=1, nfrag)]) + + ! Add the discarded bodies to the discard list + pl%status(impactors%id(:)) = MERGED + pl%ldiscard(impactors%id(:)) = .true. + pl%lcollision(impactors%id(:)) = .true. + allocate(lmask, mold=pl%lmask) + lmask(:) = .false. + lmask(impactors%id(:)) = .true. + + call plnew%setup(0, param) + deallocate(plnew) + + allocate(plsub, mold=pl) + call pl%spill(plsub, lmask, ldestructive=.false.) + + nstart = pl_discards%nbody + 1 + nend = pl_discards%nbody + nimpactors + call pl_discards%append(plsub, lsource_mask=[(.true., i = 1, nimpactors)]) + + call plsub%setup(0, param) + deallocate(plsub) + end associate + + end select + end select + + return + end subroutine collision_resolve_mergeaddsub + + + subroutine collision_resolve_list(plpl_collision , system, param, t) + !! author: David A. Minton + !! + !! Process list of collisions, determine the collisional regime, and then create fragments. + !! + implicit none + ! Arguments + class(collision_list_plpl), intent(inout) :: plpl_collision !! Swiftest pl-pl encounter list + class(base_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters with Swiftest additions + real(DP), intent(in) :: t !! Time of collision + ! Internals + ! Internals + integer(I4B), dimension(2) :: idx_parent !! Index of the two bodies considered the "parents" of the collision + logical :: lgoodcollision + integer(I4B) :: i + + select type(system) + class is (swiftest_nbody_system) + associate(ncollisions => plpl_collision%nenc, idx1 => plpl_collision%index1, idx2 => plpl_collision%index2, collision_history => system%collision_history, & + collision_system => system%collision_system, impactors => system%collision_system%impactors, fragments => system%collision_system%fragments, & + pl => system%pl, cb => system%cb) + do i = 1, ncollisions + idx_parent(1) = pl%kin(idx1(i))%parent + idx_parent(2) = pl%kin(idx2(i))%parent + lgoodcollision = collision_resolve_consolidate_impactors(pl, cb, param, idx_parent, impactors) + if ((.not. lgoodcollision) .or. any(pl%status(idx_parent(:)) /= COLLIDED)) cycle + + if (param%lfragmentation) then + call impactors%get_regime(system, param) + else + impactors%regime = COLLRESOLVE_REGIME_MERGE + fragments%mtot = sum(impactors%mass(:)) + impactors%mass_dist(1) = fragments%mtot + impactors%mass_dist(2) = 0.0_DP + impactors%mass_dist(3) = 0.0_DP + impactors%rbcom(:) = (impactors%mass(1) * impactors%rb(:,1) + impactors%mass(2) * impactors%rb(:,2)) / fragments%mtot + impactors%vbcom(:) = (impactors%mass(1) * impactors%vb(:,1) + impactors%mass(2) * impactors%vb(:,2)) / fragments%mtot + end if + + call collision_history%take_snapshot(param,system, t, "before") + select case (impactors%regime) + case (COLLRESOLVE_REGIME_DISRUPTION, COLLRESOLVE_REGIME_SUPERCATASTROPHIC) + plpl_collision%status(i) = fraggle_resolve_disruption(system, param, t) + case (COLLRESOLVE_REGIME_HIT_AND_RUN) + plpl_collision%status(i) = fraggle_resolve_hitandrun(system, param, t) + case (COLLRESOLVE_REGIME_MERGE, COLLRESOLVE_REGIME_GRAZE_AND_MERGE) + plpl_collision%status(i) = collision_resolve_merge(system, param, t) + case default + write(*,*) "Error in swiftest_collision, unrecognized collision regime" + call util_exit(FAILURE) + end select + call collision_history%take_snapshot(param,system, t, "after") + call impactors%reset() + end do + end associate + end select + return + end subroutine collision_resolve_list + + + module subroutine collision_resolve_plpl(self, system, param, t, dt, irec) + !! author: David A. Minton + !! + !! Process the pl-pl collision list, then modifiy the massive bodies based on the outcome of the collision + !! + implicit none + ! Arguments + class(collision_list_plpl), intent(inout) :: self !! Swiftest pl-pl encounter list + class(base_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters with Swiftest additions + real(DP), intent(in) :: t !! Current simulation time + real(DP), intent(in) :: dt !! Current simulation step size + integer(I4B), intent(in) :: irec !! Current recursion level + ! Internals + real(DP) :: Eorbit_before, Eorbit_after + logical :: lplpl_collision + character(len=STRMAX) :: timestr + class(swiftest_parameters), allocatable :: tmp_param + + select type (system) + class is (swiftest_nbody_system) + select type(pl => system%pl) + class is (swiftest_pl) + select type(param) + class is (swiftest_parameters) + associate(plpl_encounter => self, plpl_collision => system%plpl_collision) + if (plpl_collision%nenc == 0) return ! No collisions to resolve + ! Make sure that the heliocentric and barycentric coordinates are consistent with each other + call pl%vb2vh(system%cb) + call pl%rh2rb(system%cb) + + ! Get the energy before the collision is resolved + if (param%lenergy) then + call system%get_energy_and_momentum(param) + Eorbit_before = system%te + end if + + do + write(timestr,*) t + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "") + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "***********************************************************" // & + "***********************************************************") + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "Collision between massive bodies detected at time t = " // & + trim(adjustl(timestr))) + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "***********************************************************" // & + "***********************************************************") + allocate(tmp_param, source=param) + + call collision_resolve_list(plpl_collision, system, param, t) + + ! Destroy the collision list now that the collisions are resolved + call plpl_collision%setup(0_I8B) + + if ((system%pl_adds%nbody == 0) .and. (system%pl_discards%nbody == 0)) exit + + ! Save the add/discard information to file + call system%write_discard(tmp_param) + + ! Rearrange the arrays: Remove discarded bodies, add any new bodies, resort, and recompute all indices and encounter lists + call pl%rearray(system, tmp_param) + + ! Destroy the add/discard list so that we don't append the same body multiple times if another collision is detected + call system%pl_discards%setup(0, param) + call system%pl_adds%setup(0, param) + deallocate(tmp_param) + + ! Check whether or not any of the particles that were just added are themselves in a collision state. This will generate a new plpl_collision + call plpl_encounter%collision_check(system, param, t, dt, irec, lplpl_collision) + + if (.not.lplpl_collision) exit + end do + + if (param%lenergy) then + call system%get_energy_and_momentum(param) + Eorbit_after = system%te + system%Ecollisions = system%Ecollisions + (Eorbit_after - Eorbit_before) + end if + + end associate + end select + end select + end select + + return + end subroutine collision_resolve_plpl + + + module subroutine collision_resolve_pltp(self, system, param, t, dt, irec) + !! author: David A. Minton + !! + !! Process the pl-tp collision list, then modifiy the massive bodies based on the outcome of the collision + !! + implicit none + ! Arguments + class(collision_list_pltp), intent(inout) :: self !! Swiftest pl-pl encounter list + class(base_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters with Swiftest additions + real(DP), intent(in) :: t !! Current simulation tim + real(DP), intent(in) :: dt !! Current simulation step size + integer(I4B), intent(in) :: irec !! Current recursion level + + ! Make sure coordinate systems are all synced up due to being inside the recursion at this point + select type(system) + class is (swiftest_nbody_system) + select type(param) + class is (swiftest_parameters) + call system%pl%vb2vh(system%cb) + call system%tp%vb2vh(system%cb%vb) + call system%pl%b2h(system%cb) + call system%tp%b2h(system%cb) + + ! Discard the collider + call system%tp%discard(system, param) + end select + end select + + return + end subroutine collision_resolve_pltp + +end submodule s_collision_resolve \ No newline at end of file diff --git a/src/collision/collision_setup.f90 b/src/collision/collision_setup.f90 index d98883ca4..d3be371d3 100644 --- a/src/collision/collision_setup.f90 +++ b/src/collision/collision_setup.f90 @@ -7,89 +7,61 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule (collision_classes) s_collision_setup +submodule (collision) s_collision_setup use swiftest contains - module subroutine collision_setup_system(self, param) + module subroutine collision_setup_system(self, nbody_system) !! author: David A. Minton !! - !! Initializer for the encounter collision system. Allocates the collider and fragments classes and the before/after snapshots + !! Initializer for the encounter collision system. Sets up impactors and the before/after snapshots, + !! but not fragments. Those are setup later when the number of fragments is known. implicit none ! Arguments - class(collision_system), intent(inout) :: self !! Encounter collision system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - ! Internals + class(collision_system), intent(inout) :: self !! Encounter collision system object + class(base_nbody_system), intent(in) :: nbody_system !! Current nbody system. Used as a mold for the before/after snapshots - ! TODO: Check parameter file for fragmentation model in SyMBA - allocate(collision_impactors :: self%impactors) - allocate(fraggle_fragments :: self%fragments) + call self%setup_impactors() + if (allocated(self%before)) deallocate(self%before) + if (allocated(self%after)) deallocate(self%after) + allocate(self%before, mold=nbody_system) + allocate(self%after, mold=nbody_system) return end subroutine collision_setup_system - module subroutine collision_setup_fragments(self, n, param) + module subroutine collision_setup_impactors_system(self) !! author: David A. Minton !! - !! Allocates arrays for n fragments in a collision system. Passing n = 0 deallocates all arrays. + !! Initializer for the impactors for the encounter collision system. Deallocates old impactors before creating new ones implicit none ! Arguments - class(collision_fragments), intent(inout) :: self - integer(I4B), intent(in) :: n - class(swiftest_parameters), intent(in) :: param - - - if (n < 0) return - - call self%dealloc() - - if (n == 0) return - - self%mtot = 0.0_DP - allocate(self%status(n)) - allocate(self%rb(NDIM,n)) - allocate(self%vb(NDIM,n)) - allocate(self%mass(n)) - allocate(self%rot(NDIM,n)) - allocate(self%Ip(NDIM,n)) - - allocate(self%rc(NDIM,n)) - allocate(self%vc(NDIM,n)) - allocate(self%vmag(n)) - allocate(self%rmag(n)) - allocate(self%rotmag(n)) - allocate(self%radius(n)) - allocate(self%density(n)) - - self%status(:) = INACTIVE - self%rb(:,:) = 0.0_DP - self%vb(:,:) = 0.0_DP - self%rc(:,:) = 0.0_DP - self%vc(:,:) = 0.0_DP - self%vmag(:) = 0.0_DP - self%rmag(:) = 0.0_DP - self%rotmag(:) = 0.0_DP - self%radius(:) = 0.0_DP - self%density(:) = 0.0_DP + class(collision_system), intent(inout) :: self !! Encounter collision system object + + if (allocated(self%impactors)) deallocate(self%impactors) + allocate(collision_impactors :: self%impactors) return - end subroutine collision_setup_fragments + end subroutine collision_setup_impactors_system - module subroutine collision_setup_impactors(self, system, param) + module subroutine collision_setup_fragments_system(self, nfrag) !! author: David A. Minton !! - !! Initializes a collider object + !! Initializer for the fragments of the collision system. implicit none ! Arguments - class(collision_impactors), intent(inout) :: self !! Fragment system object - class(swiftest_nbody_system), intent(in) :: system - class(swiftest_parameters), intent(in) :: param !! Current swiftest run configuration parameters + class(collision_system), intent(inout) :: self !! Encounter collision system object + integer(I4B), intent(in) :: nfrag !! Number of fragments to create + + if (allocated(self%fragments)) deallocate(self%fragments) + allocate(collision_fragments(nfrag) :: self%fragments) return - end subroutine collision_setup_impactors + end subroutine collision_setup_fragments_system + end submodule s_collision_setup diff --git a/src/collision/collision_util.f90 b/src/collision/collision_util.f90 index 68412cfc5..0690adf60 100644 --- a/src/collision/collision_util.f90 +++ b/src/collision/collision_util.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule (collision_classes) s_collision_util +submodule (collision) s_collision_util use swiftest contains @@ -18,41 +18,44 @@ module subroutine collision_util_add_fragments_to_system(self, system, param) implicit none ! Arguments class(collision_system), intent(in) :: self !! Collision system system object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object - class(swiftest_parameters), intent(in) :: param !! Current swiftest run configuration parameters + class(base_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(base_parameters), intent(in) :: param !! Current swiftest run configuration parameters ! Internals integer(I4B) :: i, npl_before, npl_after logical, dimension(:), allocatable :: lexclude - associate(fragments => self%fragments, impactors => self%impactors, nfrag => self%fragments%nbody, pl => system%pl, cb => system%cb) - npl_after = pl%nbody - npl_before = npl_after - nfrag - allocate(lexclude(npl_after)) - - pl%status(npl_before+1:npl_after) = ACTIVE - pl%mass(npl_before+1:npl_after) = fragments%mass(1:nfrag) - pl%Gmass(npl_before+1:npl_after) = fragments%mass(1:nfrag) * param%GU - pl%radius(npl_before+1:npl_after) = fragments%radius(1:nfrag) - do concurrent (i = 1:nfrag) - pl%rb(:,npl_before+i) = fragments%rb(:,i) - pl%vb(:,npl_before+i) = fragments%vb(:,i) - pl%rh(:,npl_before+i) = fragments%rb(:,i) - cb%rb(:) - pl%vh(:,npl_before+i) = fragments%vb(:,i) - cb%vb(:) - end do - if (param%lrotation) then - pl%Ip(:,npl_before+1:npl_after) = fragments%Ip(:,1:nfrag) - pl%rot(:,npl_before+1:npl_after) = fragments%rot(:,1:nfrag) - end if - ! This will remove the impactors from the system since we've replaced them with fragments - lexclude(1:npl_after) = .false. - lexclude(impactors%idx(1:impactors%ncoll)) = .true. - where(lexclude(1:npl_after)) - pl%status(1:npl_after) = INACTIVE - elsewhere - pl%status(1:npl_after) = ACTIVE - endwhere - - end associate + select type(system) + class is (swiftest_nbody_system) + associate(fragments => self%fragments, impactors => self%impactors, nfrag => self%fragments%nbody, pl => system%pl, cb => system%cb) + npl_after = pl%nbody + npl_before = npl_after - nfrag + allocate(lexclude(npl_after)) + + pl%status(npl_before+1:npl_after) = ACTIVE + pl%mass(npl_before+1:npl_after) = fragments%mass(1:nfrag) + pl%Gmass(npl_before+1:npl_after) = fragments%mass(1:nfrag) * param%GU + pl%radius(npl_before+1:npl_after) = fragments%radius(1:nfrag) + do concurrent (i = 1:nfrag) + pl%rb(:,npl_before+i) = fragments%rb(:,i) + pl%vb(:,npl_before+i) = fragments%vb(:,i) + pl%rh(:,npl_before+i) = fragments%rb(:,i) - cb%rb(:) + pl%vh(:,npl_before+i) = fragments%vb(:,i) - cb%vb(:) + end do + if (param%lrotation) then + pl%Ip(:,npl_before+1:npl_after) = fragments%Ip(:,1:nfrag) + pl%rot(:,npl_before+1:npl_after) = fragments%rot(:,1:nfrag) + end if + ! This will remove the impactors from the system since we've replaced them with fragments + lexclude(1:npl_after) = .false. + lexclude(impactors%id(1:impactors%ncoll)) = .true. + where(lexclude(1:npl_after)) + pl%status(1:npl_after) = INACTIVE + elsewhere + pl%status(1:npl_after) = ACTIVE + endwhere + + end associate + end select return end subroutine collision_util_add_fragments_to_system @@ -64,64 +67,70 @@ module subroutine collision_util_construct_temporary_system(self, nbody_system, !! Constructs a temporary internal system consisting of active bodies and additional fragments. This internal temporary system is used to calculate system energy with and without fragments implicit none ! Arguments - class(collision_system), intent(inout) :: self !! Fraggle collision system object - class(swiftest_nbody_system), intent(in) :: nbody_system !! Original swiftest nbody system object - class(swiftest_parameters), intent(in) :: param !! Current swiftest run configuration parameters - class(swiftest_nbody_system), allocatable, intent(out) :: tmpsys !! Output temporary swiftest nbody system object - class(swiftest_parameters), allocatable, intent(out) :: tmpparam !! Output temporary configuration run parameters + class(collision_system), intent(inout) :: self !! Fraggle collision system object + class(base_nbody_system), intent(in) :: nbody_system !! Original swiftest nbody system object + class(base_parameters), intent(in) :: param !! Current swiftest run configuration parameters + class(base_nbody_system), allocatable, intent(out) :: tmpsys !! Output temporary swiftest nbody system object + class(base_parameters), allocatable, intent(out) :: tmpparam !! Output temporary configuration run parameters ! Internals logical, dimension(:), allocatable :: linclude integer(I4B) :: npl_tot - associate(fragments => self%fragments, nfrag => self%fragments%nbody, pl => nbody_system%pl, npl => nbody_system%pl%nbody, cb => nbody_system%cb) - ! Set up a new system based on the original - if (allocated(tmpparam)) deallocate(tmpparam) - if (allocated(tmpsys)) deallocate(tmpsys) - allocate(tmpparam, source=param) - call setup_construct_system(tmpsys, tmpparam) - - ! No test particles necessary for energy/momentum calcs - call tmpsys%tp%setup(0, param) - - ! Replace the empty central body object with a copy of the original - deallocate(tmpsys%cb) - allocate(tmpsys%cb, source=cb) - - ! Make space for the fragments - npl_tot = npl + nfrag - call tmpsys%pl%setup(npl_tot, tmpparam) - allocate(linclude(npl_tot)) - - ! Fill up the temporary system with all of the original bodies, leaving the spaces for fragments empty until we add them in later - linclude(1:npl) = .true. - linclude(npl+1:npl_tot) = .false. - call tmpsys%pl%fill(pl, linclude) + select type(nbody_system) + class is (swiftest_nbody_system) + select type(param) + class is (swiftest_parameters) + associate(fragments => self%fragments, nfrag => self%fragments%nbody, pl => nbody_system%pl, npl => nbody_system%pl%nbody, cb => nbody_system%cb) + ! Set up a new system based on the original + if (allocated(tmpparam)) deallocate(tmpparam) + if (allocated(tmpsys)) deallocate(tmpsys) + allocate(tmpparam, source=param) + call swiftest_setup_construct_system(tmpsys, tmpparam) + select type(tmpsys) + class is (swiftest_nbody_system) + select type(tmpparam) + class is (swiftest_parameters) + + ! No test particles necessary for energy/momentum calcs + call tmpsys%tp%setup(0, param) + + ! Replace the empty central body object with a copy of the original + deallocate(tmpsys%cb) + allocate(tmpsys%cb, source=cb) + + ! Make space for the fragments + npl_tot = npl + nfrag + call tmpsys%pl%setup(npl_tot, tmpparam) + allocate(linclude(npl_tot)) + + ! Fill up the temporary system with all of the original bodies, leaving the spaces for fragments empty until we add them in later + linclude(1:npl) = .true. + linclude(npl+1:npl_tot) = .false. + call tmpsys%pl%fill(pl, linclude) + end select + end select - end associate + end associate + end select + end select return end subroutine collision_util_construct_temporary_system - module subroutine collision_util_dealloc_fragments(self) + + module subroutine collision_util_final_fragments(self) !! author: David A. Minton !! - !! Deallocates all allocatables + !! Finalizer will deallocate all allocatables implicit none ! Arguments - class(collision_fragments), intent(inout) :: self - - call util_dealloc_pl(self) + type(collision_fragments(*)), intent(inout) :: self - if (allocated(self%rc)) deallocate(self%rc) - if (allocated(self%vc)) deallocate(self%vc) - if (allocated(self%rmag)) deallocate(self%rmag) - if (allocated(self%rotmag)) deallocate(self%rotmag) - if (allocated(self%v_r_unit)) deallocate(self%v_r_unit) - if (allocated(self%v_t_unit)) deallocate(self%v_t_unit) - if (allocated(self%v_n_unit)) deallocate(self%v_n_unit) + call self%reset() return - end subroutine collision_util_dealloc_fragments + end subroutine collision_util_final_fragments + module subroutine collision_util_final_impactors(self) !! author: David A. Minton @@ -158,8 +167,12 @@ module subroutine collision_util_final_storage(self) implicit none ! Arguments type(collision_storage(*)), intent(inout) :: self !! Collision storage object + ! Internals + integer(I4B) :: i - call util_final_storage(self%swiftest_storage) + do i = 1, self%nframes + if (allocated(self%frame(i)%item)) deallocate(self%frame(i)%item) + end do return end subroutine collision_util_final_storage @@ -172,10 +185,8 @@ module subroutine collision_util_final_system(self) implicit none ! Arguments type(collision_system), intent(inout) :: self !! Collision system object - ! Internals - type(swiftest_parameters) :: tmp_param - call self%reset(tmp_param) + call self%reset() if (allocated(self%impactors)) deallocate(self%impactors) if (allocated(self%fragments)) deallocate(self%fragments) @@ -194,36 +205,42 @@ module subroutine collision_util_get_idvalues_snapshot(self, idvals) ! Internals integer(I4B) :: npl_before, ntp_before, npl_after, ntp_after, ntot, nlo, nhi - npl_before = 0; ntp_before = 0; npl_after = 0; ntp_after = 0 - if (allocated(self%collision_system%before%pl)) then - npl_before = self%collision_system%before%pl%nbody - endif - - if (allocated(self%collision_system%before%tp)) then - ntp_before = self%collision_system%before%tp%nbody - end if + select type(before => self%collision_system%before) + class is (swiftest_nbody_system) + select type(after => self%collision_system%after) + class is (swiftest_nbody_system) + npl_before = 0; ntp_before = 0; npl_after = 0; ntp_after = 0 + if (allocated(before%pl)) then + npl_before = before%pl%nbody + endif + + if (allocated(before%tp)) then + ntp_before = before%tp%nbody + end if - if (allocated(self%collision_system%after%pl)) then - npl_after = self%collision_system%after%pl%nbody - end if + if (allocated(after%pl)) then + npl_after = after%pl%nbody + end if - if (allocated(self%collision_system%after%tp)) then - ntp_after = self%collision_system%after%tp%nbody - end if + if (allocated(after%tp)) then + ntp_after = after%tp%nbody + end if - ntot = npl_before + ntp_before + npl_after + ntp_after - if (ntot == 0) return - allocate(idvals(ntot)) + ntot = npl_before + ntp_before + npl_after + ntp_after + if (ntot == 0) return + allocate(idvals(ntot)) - nlo = 1; nhi = npl_before - if (npl_before > 0) idvals(nlo:nhi) = self%collision_system%before%pl%id(1:npl_before) - nlo = nhi + 1; nhi = nhi + ntp_before - if (ntp_before > 0) idvals(nlo:nhi) = self%collision_system%before%tp%id(1:ntp_before) + nlo = 1; nhi = npl_before + if (npl_before > 0) idvals(nlo:nhi) = before%pl%id(1:npl_before) + nlo = nhi + 1; nhi = nhi + ntp_before + if (ntp_before > 0) idvals(nlo:nhi) = before%tp%id(1:ntp_before) - nlo = nhi + 1; nhi = nhi + npl_after - if (npl_after > 0) idvals(nlo:nhi) = self%collision_system%after%pl%id(1:npl_after) - nlo = nhi + 1; nhi = nhi + ntp_after - if (ntp_after > 0) idvals(nlo:nhi) = self%collision_system%after%tp%id(1:ntp_after) + nlo = nhi + 1; nhi = nhi + npl_after + if (npl_after > 0) idvals(nlo:nhi) = after%pl%id(1:npl_after) + nlo = nhi + 1; nhi = nhi + ntp_after + if (ntp_after > 0) idvals(nlo:nhi) = after%tp%id(1:ntp_after) + end select + end select return @@ -239,61 +256,76 @@ module subroutine collision_util_get_energy_momentum(self, system, param, lbefo !! This will temporarily expand the massive body object in a temporary system object called tmpsys to feed it into symba_energy implicit none ! Arguments - class(collision_system), intent(inout) :: self !! Encounter collision system object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current swiftest run configuration parameters - logical, intent(in) :: lbefore !! Flag indicating that this the "before" state of the system, with impactors included and fragments excluded or vice versa + class(collision_system), intent(inout) :: self !! Encounter collision system object + class(base_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(base_parameters), intent(inout) :: param !! Current swiftest run configuration parameters + logical, intent(in) :: lbefore !! Flag indicating that this the "before" state of the system, with impactors included and fragments excluded or vice versa ! Internals - class(swiftest_nbody_system), allocatable, save :: tmpsys - class(swiftest_parameters), allocatable, save :: tmpparam + class(base_nbody_system), allocatable, save :: tmpsys + class(base_parameters), allocatable, save :: tmpparam integer(I4B) :: npl_before, npl_after, stage - associate(fragments => self%fragments, impactors => self%impactors, nfrag => self%fragments%nbody, pl => system%pl, cb => system%cb) - - ! Because we're making a copy of the massive body object with the excludes/fragments appended, we need to deallocate the - ! big k_plpl array and recreate it when we're done, otherwise we run the risk of blowing up the memory by - ! allocating two of these ginormous arrays simulteouously. This is not particularly efficient, but as this - ! subroutine should be called relatively infrequently, it shouldn't matter too much. - - npl_before = pl%nbody - npl_after = npl_before + nfrag - - if (lbefore) then - call self%construct_temporary_system(system, param, tmpsys, tmpparam) - ! Build the exluded body logical mask for the *before* case: Only the original bodies are used to compute energy and momentum - tmpsys%pl%status(impactors%idx(1:impactors%ncoll)) = ACTIVE - tmpsys%pl%status(npl_before+1:npl_after) = INACTIVE - else - if (.not.allocated(tmpsys)) then - write(*,*) "Error in collision_util_get_energy_momentum. " // & - " This must be called with lbefore=.true. at least once before calling it with lbefore=.false." - call util_exit(FAILURE) - end if - ! Build the exluded body logical mask for the *after* case: Only the new bodies are used to compute energy and momentum - call self%add_fragments(tmpsys, tmpparam) - tmpsys%pl%status(impactors%idx(1:impactors%ncoll)) = INACTIVE - tmpsys%pl%status(npl_before+1:npl_after) = ACTIVE - end if - - if (param%lflatten_interactions) call tmpsys%pl%flatten(param) - - call tmpsys%get_energy_and_momentum(param) - - ! Calculate the current fragment energy and momentum balances - if (lbefore) then - stage = 1 - else - stage = 2 - end if - self%Lorbit(:,stage) = tmpsys%Lorbit(:) - self%Lspin(:,stage) = tmpsys%Lspin(:) - self%Ltot(:,stage) = tmpsys%Ltot(:) - self%ke_orbit(stage) = tmpsys%ke_orbit - self%ke_spin(stage) = tmpsys%ke_spin - self%pe(stage) = tmpsys%pe - self%Etot(stage) = tmpsys%te - if (stage == 2) self%Etot(stage) = self%Etot(stage) - (self%pe(2) - self%pe(1)) ! Gotta be careful with PE when number of bodies changes. - end associate + select type(system) + class is (swiftest_nbody_system) + select type(param) + class is (swiftest_parameters) + associate(fragments => self%fragments, impactors => self%impactors, nfrag => self%fragments%nbody, pl => system%pl, cb => system%cb) + + ! Because we're making a copy of the massive body object with the excludes/fragments appended, we need to deallocate the + ! big k_plpl array and recreate it when we're done, otherwise we run the risk of blowing up the memory by + ! allocating two of these ginormous arrays simulteouously. This is not particularly efficient, but as this + ! subroutine should be called relatively infrequently, it shouldn't matter too much. + + npl_before = pl%nbody + npl_after = npl_before + nfrag + + if (lbefore) then + call self%construct_temporary_system(system, param, tmpsys, tmpparam) + select type(tmpsys) + class is (swiftest_nbody_system) + ! Build the exluded body logical mask for the *before* case: Only the original bodies are used to compute energy and momentum + tmpsys%pl%status(impactors%id(1:impactors%ncoll)) = ACTIVE + tmpsys%pl%status(npl_before+1:npl_after) = INACTIVE + end select + else + if (.not.allocated(tmpsys)) then + write(*,*) "Error in collision_util_get_energy_momentum. " // & + " This must be called with lbefore=.true. at least once before calling it with lbefore=.false." + call util_exit(FAILURE) + end if + select type(tmpsys) + class is (swiftest_nbody_system) + ! Build the exluded body logical mask for the *after* case: Only the new bodies are used to compute energy and momentum + call self%add_fragments(tmpsys, tmpparam) + tmpsys%pl%status(impactors%id(1:impactors%ncoll)) = INACTIVE + tmpsys%pl%status(npl_before+1:npl_after) = ACTIVE + end select + end if + select type(tmpsys) + class is (swiftest_nbody_system) + + if (param%lflatten_interactions) call tmpsys%pl%flatten(param) + + call tmpsys%get_energy_and_momentum(param) + + ! Calculate the current fragment energy and momentum balances + if (lbefore) then + stage = 1 + else + stage = 2 + end if + self%Lorbit(:,stage) = tmpsys%Lorbit(:) + self%Lspin(:,stage) = tmpsys%Lspin(:) + self%Ltot(:,stage) = tmpsys%Ltot(:) + self%ke_orbit(stage) = tmpsys%ke_orbit + self%ke_spin(stage) = tmpsys%ke_spin + self%pe(stage) = tmpsys%pe + self%Etot(stage) = tmpsys%te + if (stage == 2) self%Etot(stage) = self%Etot(stage) - (self%pe(2) - self%pe(1)) ! Gotta be careful with PE when number of bodies changes. + end select + end associate + end select + end select return end subroutine collision_util_get_energy_momentum @@ -322,43 +354,6 @@ module subroutine collision_util_index_map(self) return end subroutine collision_util_index_map - !> The following interfaces are placeholders intended to satisfy the required abstract methods given by the parent class - module subroutine collision_util_placeholder_accel(self, system, param, t, lbeg) - implicit none - class(collision_fragments), intent(inout) :: self !! Fraggle fragment system object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - real(DP), intent(in) :: t !! Current simulation time - logical, intent(in) :: lbeg !! Optional argument that determines whether or not this is the beginning or end of the step - write(*,*) "The type-bound procedure 'accel' is not defined for the collision_fragments class" - return - end subroutine collision_util_placeholder_accel - - module subroutine collision_util_placeholder_kick(self, system, param, t, dt, lbeg) - implicit none - class(collision_fragments), intent(inout) :: self !! Fraggle fragment system object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system objec - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - real(DP), intent(in) :: t !! Current time - real(DP), intent(in) :: dt !! Stepsize - logical, intent(in) :: lbeg !! Logical flag indicating whether this is the beginning of the half step or not. - - write(*,*) "The type-bound procedure 'kick' is not defined for the collision_fragments class" - return - end subroutine collision_util_placeholder_kick - - module subroutine collision_util_placeholder_step(self, system, param, t, dt) - implicit none - class(collision_fragments), intent(inout) :: self !! Swiftest body object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - real(DP), intent(in) :: t !! Simulation time - real(DP), intent(in) :: dt !! Current stepsize - - write(*,*) "The type-bound procedure 'step' is not defined for the collision_fragments class" - return - end subroutine collision_util_placeholder_step - module subroutine collision_util_reset_impactors(self) !! author: David A. Minton @@ -368,7 +363,7 @@ module subroutine collision_util_reset_impactors(self) ! Arguments class(collision_impactors), intent(inout) :: self - if (allocated(self%idx)) deallocate(self%idx) + if (allocated(self%id)) deallocate(self%id) if (allocated(self%mass_dist)) deallocate(self%mass_dist) self%ncoll = 0 self%rb(:,:) = 0.0_DP @@ -393,14 +388,44 @@ module subroutine collision_util_reset_impactors(self) return end subroutine collision_util_reset_impactors - module subroutine collision_util_reset_system(self, param) + + module subroutine collision_util_reset_fragments(self) + !! author: David A. Minton + !! + !! Deallocates all allocatables + implicit none + ! Arguments + class(collision_fragments(*)), intent(inout) :: self + + if (allocated(self%info)) deallocate(self%info) + self%mtot = 0.0_DP + self%status = 0 + self%rh(:,:) = 0.0_DP + self%vh(:,:) = 0.0_DP + self%rb(:,:) = 0.0_DP + self%vb(:,:) = 0.0_DP + self%rot(:,:) = 0.0_DP + self%Ip(:,:) = 0.0_DP + self%mass(:) = 0.0_DP + self%radius(:) = 0.0_DP + self%density(:) = 0.0_DP + self%rc(:,:) = 0.0_DP + self%vc(:,:) = 0.0_DP + self%v_r_unit(:,:) = 0.0_DP + self%v_t_unit(:,:) = 0.0_DP + self%v_n_unit(:,:) = 0.0_DP + + return + end subroutine collision_util_reset_fragments + + + module subroutine collision_util_reset_system(self) !! author: David A. Minton !! !! Resets the collider system and deallocates all allocatables implicit none ! Arguments class(collision_system), intent(inout) :: self !! Collision system object - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters if (allocated(self%before)) deallocate(self%before) if (allocated(self%after)) deallocate(self%after) @@ -414,7 +439,7 @@ module subroutine collision_util_reset_system(self, param) self%Etot(:) = 0.0_DP if (allocated(self%impactors)) call self%impactors%reset() - if (allocated(self%fragments)) call self%fragments%setup(0, param) + if (allocated(self%fragments)) deallocate(self%fragments) return end subroutine collision_util_reset_system @@ -486,7 +511,7 @@ subroutine collision_util_save_snapshot(collision_history, snapshot) !! Memory usage grows by a factor of 2 each time it fills up, but no more. implicit none ! Arguments - type(collision_storage(*)), allocatable, intent(inout) :: collision_history !! Collision history object + class(collision_storage(*)), allocatable, intent(inout) :: collision_history !! Collision history object class(encounter_snapshot), intent(in) :: snapshot !! Encounter snapshot object ! Internals type(collision_storage(nframes=:)), allocatable :: tmp @@ -529,14 +554,14 @@ module subroutine collision_util_snapshot(self, param, system, t, arg) !! can be played back through the encounter implicit none ! Internals - class(collision_storage(*)), intent(inout) :: self !! Swiftest storage object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object to store - real(DP), intent(in), optional :: t !! Time of snapshot if different from system time - character(*), intent(in), optional :: arg !! "before": takes a snapshot just before the collision. "after" takes the snapshot just after the collision. + class(collision_storage(*)), intent(inout) :: self !! Swiftest storage object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + class(base_nbody_system), intent(inout) :: system !! Swiftest nbody system object to store + real(DP), intent(in), optional :: t !! Time of snapshot if different from system time + character(*), intent(in), optional :: arg !! "before": takes a snapshot just before the collision. "after" takes the snapshot just after the collision. ! Arguments class(collision_snapshot), allocatable :: snapshot - type(symba_pl) :: pl + class(swiftest_pl), allocatable :: pl character(len=:), allocatable :: stage if (present(arg)) then @@ -546,12 +571,13 @@ module subroutine collision_util_snapshot(self, param, system, t, arg) end if select type (system) - class is (symba_nbody_system) - + class is (swiftest_nbody_system) + select type(param) + class is (swiftest_parameters) select case(stage) case("before") ! Saves the states of the bodies involved in the collision before the collision is resolved - associate (idx => system%collision_system%impactors%idx, ncoll => system%collision_system%impactors%ncoll) + associate (idx => system%collision_system%impactors%id, ncoll => system%collision_system%impactors%ncoll) call pl%setup(ncoll, param) pl%id(:) = system%pl%id(idx(:)) pl%Gmass(:) = system%pl%Gmass(idx(:)) @@ -561,21 +587,20 @@ module subroutine collision_util_snapshot(self, param, system, t, arg) pl%rh(:,:) = system%pl%rh(:,idx(:)) pl%vh(:,:) = system%pl%vh(:,idx(:)) pl%info(:) = system%pl%info(idx(:)) - !end select - allocate(system%collision_system%before%pl, source=pl) + select type (before => system%collision_system%before) + class is (swiftest_nbody_system) + allocate(before%pl, source=pl) + end select end associate case("after") allocate(collision_snapshot :: snapshot) allocate(snapshot%collision_system, source=system%collision_system) snapshot%t = t - select type(param) - class is (symba_parameters) - call collision_util_save_snapshot(param%collision_history,snapshot) - end select + call collision_util_save_snapshot(system%collision_history,snapshot) case default write(*,*) "collision_util_snapshot requies either 'before' or 'after' passed to 'arg'" end select - + end select end select return diff --git a/src/encounter/encounter_check.f90 b/src/encounter/encounter_check.f90 index 4e60ecf4f..f3a5a3f8d 100644 --- a/src/encounter/encounter_check.f90 +++ b/src/encounter/encounter_check.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule (encounter_classes) s_encounter_check +submodule (encounter) s_encounter_check use swiftest contains @@ -19,7 +19,7 @@ module subroutine encounter_check_all_plpl(param, npl, x, v, renc, dt, & !! implicit none ! Arguments - class(swiftest_parameters), intent(inout) :: param !! Current Swiftest run configuration parameter5s + class(base_parameters), intent(inout) :: param !! Current Swiftest run configuration parameter5s integer(I4B), intent(in) :: npl !! Total number of massive bodies real(DP), dimension(:,:), intent(in) :: x !! Position vectors of massive bodies real(DP), dimension(:,:), intent(in) :: v !! Velocity vectors of massive bodies @@ -30,43 +30,43 @@ module subroutine encounter_check_all_plpl(param, npl, x, v, renc, dt, & integer(I4B), dimension(:), allocatable, intent(out) :: index2 !! List of indices for body 2 in each encounter logical, dimension(:), allocatable, intent(out) :: lvdotr !! Logical flag indicating the sign of v .dot. x ! Internals - type(interaction_timer), save :: itimer + !type(interaction_timer), save :: itimer logical, save :: lfirst = .true. logical, save :: skipit = .false. ! This will be used to ensure that the sort & sweep subroutine gets called at least once before timing it so that the extent array is nearly sorted when it is timed integer(I8B) :: nplpl = 0_I8B - if (param%ladaptive_encounters_plpl .and. (.not. skipit)) then - nplpl = (npl * (npl - 1) / 2) - if (nplpl > 0) then - if (lfirst) then - write(itimer%loopname, *) "encounter_check_all_plpl" - write(itimer%looptype, *) "ENCOUNTER_PLPL" - lfirst = .false. - itimer%step_counter = INTERACTION_TIMER_CADENCE - else - if (itimer%check(param, nplpl)) call itimer%time_this_loop(param, nplpl) - end if - else - param%lencounter_sas_plpl = .false. - end if - end if + ! if (param%ladaptive_encounters_plpl .and. (.not. skipit)) then + ! nplpl = (npl * (npl - 1) / 2) + ! if (nplpl > 0) then + ! if (lfirst) then + ! write(itimer%loopname, *) "encounter_check_all_plpl" + ! write(itimer%looptype, *) "ENCOUNTER_PLPL" + ! lfirst = .false. + ! itimer%step_counter = INTERACTION_TIMER_CADENCE + ! else + ! if (itimer%io_netcdf_check(param, nplpl)) call itimer%time_this_loop(param, nplpl) + ! end if + ! else + ! param%lencounter_sas_plpl = .false. + ! end if + ! end if - if (param%lencounter_sas_plpl) then - call encounter_check_all_sort_and_sweep_plpl(npl, x, v, renc, dt, nenc, index1, index2, lvdotr) - else + ! if (param%lencounter_sas_plpl) then + ! call encounter_check_all_sort_and_sweep_plpl(npl, x, v, renc, dt, nenc, index1, index2, lvdotr) + ! else call encounter_check_all_triangular_plpl(npl, x, v, renc, dt, nenc, index1, index2, lvdotr) - end if - - if (skipit) then - skipit = .false. - else - if (param%ladaptive_encounters_plpl .and. nplpl > 0) then - if (itimer%is_on) then - call itimer%adapt(param, nplpl) - skipit = .true. - end if - end if - end if + ! end if + + ! if (skipit) then + ! skipit = .false. + ! else + ! if (param%ladaptive_encounters_plpl .and. nplpl > 0) then + ! if (itimer%is_on) then + ! call itimer%adapt(param, nplpl) + ! skipit = .true. + ! end if + ! end if + ! end if return end subroutine encounter_check_all_plpl @@ -80,7 +80,7 @@ module subroutine encounter_check_all_plplm(param, nplm, nplt, xplm, vplm, xplt, !! implicit none ! Arguments - class(swiftest_parameters), intent(inout) :: param !! Current Swiftest run configuration parameter5s + class(base_parameters), intent(inout) :: param !! Current Swiftest run configuration parameter5s integer(I4B), intent(in) :: nplm !! Total number of fully interacting massive bodies integer(I4B), intent(in) :: nplt !! Total number of partially interacting masive bodies (GM < GMTINY) real(DP), dimension(:,:), intent(in) :: xplm !! Position vectors of fully interacting massive bodies @@ -95,7 +95,7 @@ module subroutine encounter_check_all_plplm(param, nplm, nplt, xplm, vplm, xplt, integer(I4B), dimension(:), allocatable, intent(out) :: index2 !! List of indices for body 2 in each encounter logical, dimension(:), allocatable, intent(out) :: lvdotr !! Logical flag indicating the sign of v .dot. x ! Internals - type(interaction_timer), save :: itimer + ! type(interaction_timer), save :: itimer logical, save :: lfirst = .true. logical, save :: skipit = .false. integer(I8B) :: nplplm = 0_I8B @@ -104,27 +104,27 @@ module subroutine encounter_check_all_plplm(param, nplm, nplt, xplm, vplm, xplt, integer(I4B), dimension(:), allocatable :: plmplt_index1 !! List of indices for body 1 in each encounter in the plm-plt group integer(I4B), dimension(:), allocatable :: plmplt_index2 !! List of indices for body 2 in each encounter in the plm-lt group integer(I8B) :: plmplt_nenc !! Number of encounters of the plm-plt group - class(swiftest_parameters), allocatable :: tmp_param !! Temporary parameter structure to turn off adaptive timer for the pl-pl phase if necessary + class(base_parameters), allocatable :: tmp_param !! Temporary parameter structure to turn off adaptive timer for the pl-pl phase if necessary integer(I8B), dimension(:), allocatable :: ind integer(I4B), dimension(:), allocatable :: itmp logical, dimension(:), allocatable :: ltmp - if (param%ladaptive_encounters_plpl .and. (.not. skipit)) then - npl = nplm + nplt - nplplm = nplm * npl - nplm * (nplm + 1) / 2 - if (nplplm > 0) then - if (lfirst) then - write(itimer%loopname, *) "encounter_check_all_plpl" - write(itimer%looptype, *) "ENCOUNTER_PLPL" - lfirst = .false. - itimer%step_counter = INTERACTION_TIMER_CADENCE - else - if (itimer%check(param, nplplm)) call itimer%time_this_loop(param, nplplm) - end if - else - param%lencounter_sas_plpl = .false. - end if - end if + ! if (param%ladaptive_encounters_plpl .and. (.not. skipit)) then + ! npl = nplm + nplt + ! nplplm = nplm * npl - nplm * (nplm + 1) / 2 + ! if (nplplm > 0) then + ! if (lfirst) then + ! write(itimer%loopname, *) "encounter_check_all_plpl" + ! write(itimer%looptype, *) "ENCOUNTER_PLPL" + ! lfirst = .false. + ! itimer%step_counter = INTERACTION_TIMER_CADENCE + ! else + ! if (itimer%io_netcdf_check(param, nplplm)) call itimer%time_this_loop(param, nplplm) + ! end if + ! else + ! param%lencounter_sas_plpl = .false. + ! end if + ! end if allocate(tmp_param, source=param) @@ -134,24 +134,24 @@ module subroutine encounter_check_all_plplm(param, nplm, nplt, xplm, vplm, xplt, ! Start with the pl-pl group call encounter_check_all_plpl(tmp_param, nplm, xplm, vplm, rencm, dt, nenc, index1, index2, lvdotr) - if (param%lencounter_sas_plpl) then - call encounter_check_all_sort_and_sweep_plplm(nplm, nplt, xplm, vplm, xplt, vplt, rencm, renct, dt, & - plmplt_nenc, plmplt_index1, plmplt_index2, plmplt_lvdotr) - else + ! if (param%lencounter_sas_plpl) then + ! call encounter_check_all_sort_and_sweep_plplm(nplm, nplt, xplm, vplm, xplt, vplt, rencm, renct, dt, & + ! plmplt_nenc, plmplt_index1, plmplt_index2, plmplt_lvdotr) + ! else call encounter_check_all_triangular_plplm(nplm, nplt, xplm, vplm, xplt, vplt, rencm, renct, dt, & plmplt_nenc, plmplt_index1, plmplt_index2, plmplt_lvdotr) - end if - - if (skipit) then - skipit = .false. - else - if (param%ladaptive_encounters_plpl .and. nplplm > 0) then - if (itimer%is_on) then - call itimer%adapt(param, nplplm) - skipit = .true. - end if - end if - end if + ! end if + + ! if (skipit) then + ! skipit = .false. + ! else + ! if (param%ladaptive_encounters_plpl .and. nplplm > 0) then + ! if (itimer%is_on) then + ! call itimer%adapt(param, nplplm) + ! skipit = .true. + ! end if + ! end if + ! end if if (plmplt_nenc > 0) then ! Consolidate the two lists allocate(itmp(nenc+plmplt_nenc)) @@ -187,7 +187,7 @@ module subroutine encounter_check_all_pltp(param, npl, ntp, xpl, vpl, xtp, vtp, !! implicit none ! Arguments - class(swiftest_parameters), intent(inout) :: param !! Current Swiftest run configuration parameter5s + class(base_parameters), intent(inout) :: param !! Current Swiftest run configuration parameter5s integer(I4B), intent(in) :: npl !! Total number of massive bodies integer(I4B), intent(in) :: ntp !! Total number of test particles real(DP), dimension(:,:), intent(in) :: xpl !! Position vectors of massive bodies @@ -201,42 +201,42 @@ module subroutine encounter_check_all_pltp(param, npl, ntp, xpl, vpl, xtp, vtp, integer(I4B), dimension(:), allocatable, intent(out) :: index2 !! List of indices for body 2 in each encounter logical, dimension(:), allocatable, intent(out) :: lvdotr !! Logical flag indicating the sign of v .dot. x ! Internals - type(interaction_timer), save :: itimer + ! type(interaction_timer), save :: itimer logical, save :: lfirst = .true. logical, save :: lsecond = .false. integer(I8B) :: npltp = 0_I8B - if (param%ladaptive_encounters_pltp) then - npltp = npl * ntp - if (npltp > 0) then - if (lfirst) then - write(itimer%loopname, *) "encounter_check_all_pltp" - write(itimer%looptype, *) "ENCOUNTER_PLTP" - lfirst = .false. - lsecond = .true. - else - if (lsecond) then ! This ensures that the encounter check methods are run at least once prior to timing. Sort and sweep improves on the second pass due to the bounding box extents needing to be nearly sorted - call itimer%time_this_loop(param, npltp) - lsecond = .false. - else if (itimer%check(param, npltp)) then - lsecond = .true. - itimer%is_on = .false. - end if - end if - else - param%lencounter_sas_pltp = .false. - end if - end if - - if (param%lencounter_sas_pltp) then - call encounter_check_all_sort_and_sweep_pltp(npl, ntp, xpl, vpl, xtp, vtp, renc, dt, nenc, index1, index2, lvdotr) - else + ! if (param%ladaptive_encounters_pltp) then + ! npltp = npl * ntp + ! if (npltp > 0) then + ! if (lfirst) then + ! write(itimer%loopname, *) "encounter_check_all_pltp" + ! write(itimer%looptype, *) "ENCOUNTER_PLTP" + ! lfirst = .false. + ! lsecond = .true. + ! else + ! if (lsecond) then ! This ensures that the encounter check methods are run at least once prior to timing. Sort and sweep improves on the second pass due to the bounding box extents needing to be nearly sorted + ! call itimer%time_this_loop(param, npltp) + ! lsecond = .false. + ! else if (itimer%io_netcdf_check(param, npltp)) then + ! lsecond = .true. + ! itimer%is_on = .false. + ! end if + ! end if + ! else + ! param%lencounter_sas_pltp = .false. + ! end if + ! end if + + ! if (param%lencounter_sas_pltp) then + ! call encounter_check_all_sort_and_sweep_pltp(npl, ntp, xpl, vpl, xtp, vtp, renc, dt, nenc, index1, index2, lvdotr) + ! else call encounter_check_all_triangular_pltp(npl, ntp, xpl, vpl, xtp, vtp, renc, dt, nenc, index1, index2, lvdotr) - end if + ! end if - if (.not.lfirst .and. param%ladaptive_encounters_pltp .and. npltp > 0) then - if (itimer%is_on) call itimer%adapt(param, npltp) - end if + ! if (.not.lfirst .and. param%ladaptive_encounters_pltp .and. npltp > 0) then + ! if (itimer%is_on) call itimer%adapt(param, npltp) + ! end if return end subroutine encounter_check_all_pltp @@ -514,7 +514,7 @@ pure subroutine encounter_check_all_triangular_one(i, n, xi, yi, zi, vxi, vyi, v real(DP), dimension(:), intent(in) :: renc !! Array of encounter radii of all bodies real(DP), intent(in) :: dt !! Step size integer(I4B), dimension(:), intent(in) :: ind_arr !! Index array [1, 2, ..., n] - type(encounter_list), intent(out) :: lenci !! Output encounter lists containing number of encounters, the v.dot.r direction array, and the index list of encountering bodies + class(encounter_list), intent(out) :: lenci !! Output encounter lists containing number of encounters, the v.dot.r direction array, and the index list of encountering bodies ! Internals integer(I4B) :: j integer(I8B) :: nenci @@ -563,7 +563,7 @@ subroutine encounter_check_all_triangular_plpl(npl, x, v, renc, dt, nenc, index1 ! Internals integer(I4B) :: i integer(I4B), dimension(:), allocatable, save :: ind_arr - type(encounter_list), dimension(npl) :: lenc + type(collision_list_plpl), dimension(npl) :: lenc call util_index_array(ind_arr, npl) @@ -610,7 +610,7 @@ subroutine encounter_check_all_triangular_plplm(nplm, nplt, xplm, vplm, xplt, vp ! Internals integer(I4B) :: i integer(I4B), dimension(:), allocatable, save :: ind_arr - type(encounter_list), dimension(nplm) :: lenc + type(collision_list_plpl), dimension(nplm) :: lenc call util_index_array(ind_arr, nplt) @@ -656,7 +656,7 @@ subroutine encounter_check_all_triangular_pltp(npl, ntp, xpl, vpl, xtp, vtp, ren ! Internals integer(I4B) :: i integer(I4B), dimension(:), allocatable, save :: ind_arr - type(encounter_list), dimension(npl) :: lenc + type(collision_list_pltp), dimension(npl) :: lenc real(DP), dimension(ntp) :: renct call util_index_array(ind_arr, ntp) @@ -734,7 +734,7 @@ module subroutine encounter_check_collapse_ragged_list(ragged_list, n1, nenc, in !! Collapses a ragged index list (one encounter list per body) into a pair of index arrays and a vdotr logical array (optional) implicit none ! Arguments - type(encounter_list), dimension(:), intent(in) :: ragged_list !! The ragged encounter list + class(encounter_list), dimension(:), intent(in) :: ragged_list !! The ragged encounter list integer(I4B), intent(in) :: n1 !! Number of bodies 1 integer(I8B), intent(out) :: nenc !! Total number of encountersj integer(I4B), dimension(:), allocatable, intent(out) :: index1 !! Array of indices for body 1 @@ -917,7 +917,7 @@ module subroutine encounter_check_sweep_aabb_double_list(self, n1, n2, r1, v1, r logical, dimension(SWEEPDIM,n1+n2) :: loverlap_by_dimension logical, dimension(SWEEPDIM,2*(n1+n2)) :: llist1 integer(I4B), dimension(SWEEPDIM,2*(n1+n2)) :: ext_ind - type(encounter_list), dimension(n1+n2) :: lenc !! Array of encounter lists (one encounter list per body) + type(collision_list_pltp), dimension(n1+n2) :: lenc !! Array of encounter lists (one encounter list per body) integer(I4B), dimension(:), allocatable, save :: ind_arr integer(I8B) :: ibeg, iend real(DP), dimension(2*(n1+n2)) :: xind, yind, zind, vxind, vyind, vzind, rencind @@ -1012,7 +1012,7 @@ module subroutine encounter_check_sweep_aabb_single_list(self, n, x, v, renc, dt !! author: David A. Minton !! !! Sweeps the sorted bounding box extents and returns the true encounters (combines broad and narrow phases) - !! Double list version (e.g. pl-tp or plm-plt) + !! Single list version (e.g. pl-pl) implicit none ! Arguments class(encounter_bounding_box), intent(inout) :: self !! Multi-dimensional bounding box structure @@ -1031,7 +1031,7 @@ module subroutine encounter_check_sweep_aabb_single_list(self, n, x, v, renc, dt logical, dimension(2*n) :: lencounteri real(DP), dimension(2*n) :: xind, yind, zind, vxind, vyind, vzind, rencind integer(I4B), dimension(SWEEPDIM,2*n) :: ext_ind - type(encounter_list), dimension(n) :: lenc !! Array of encounter lists (one encounter list per body) + type(collision_list_plpl), dimension(n) :: lenc !! Array of encounter lists (one encounter list per body) integer(I4B), dimension(:), allocatable, save :: ind_arr integer(I8B) :: ibeg, iend diff --git a/src/encounter/encounter_io.f90 b/src/encounter/encounter_io.f90 index 70b782948..b92b9a2fd 100644 --- a/src/encounter/encounter_io.f90 +++ b/src/encounter/encounter_io.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule (encounter_classes) s_encounter_io +submodule (encounter) s_encounter_io use swiftest contains @@ -18,7 +18,7 @@ module subroutine encounter_io_dump(self, param) implicit none ! Arguments class(encounter_storage(*)), intent(inout) :: self !! Encounter storage object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(base_parameters), intent(inout) :: param !! Current run configuration parameters ! Internals integer(I4B) :: i @@ -38,7 +38,7 @@ module subroutine encounter_io_dump(self, param) select type(snapshot => self%frame(i)%item) class is (encounter_snapshot) param%ioutput = self%tmap(i) - call snapshot%write_frame(nc,param) + call snapshot%write_frame(self,param) end select else exit @@ -63,7 +63,7 @@ module subroutine encounter_io_initialize_output(self, param) implicit none ! Arguments class(encounter_io_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters + class(base_parameters), intent(in) :: param !! Current run configuration parameters ! Internals integer(I4B) :: nvar, varid, vartype real(DP) :: dfill @@ -91,54 +91,54 @@ module subroutine encounter_io_initialize_output(self, param) close(unit=LUN, status="delete") end if - call check( nf90_create(nc%file_name, NF90_NETCDF4, nc%id), "encounter_io_initialize_output nf90_create" ) + call netcdf_check( nf90_create(nc%file_name, NF90_NETCDF4, nc%id), "encounter_io_initialize_output nf90_create" ) ! Dimensions - call check( nf90_def_dim(nc%id, nc%time_dimname, nc%time_dimsize, nc%time_dimid), "encounter_io_initialize_output nf90_def_dim time_dimid" ) ! Simulation time dimension - call check( nf90_def_dim(nc%id, nc%space_dimname, NDIM, nc%space_dimid), "encounter_io_initialize_output nf90_def_dim space_dimid" ) ! 3D space dimension - call check( nf90_def_dim(nc%id, nc%name_dimname, nc%name_dimsize, nc%name_dimid), "encounter_io_initialize_output nf90_def_dim name_dimid" ) ! dimension to store particle id numbers - call check( nf90_def_dim(nc%id, nc%str_dimname, NAMELEN, nc%str_dimid), "encounter_io_initialize_output nf90_def_dim str_dimid" ) ! Dimension for string variables (aka character arrays) + call netcdf_check( nf90_def_dim(nc%id, nc%time_dimname, nc%time_dimsize, nc%time_dimid), "encounter_io_initialize_output nf90_def_dim time_dimid" ) ! Simulation time dimension + call netcdf_check( nf90_def_dim(nc%id, nc%space_dimname, NDIM, nc%space_dimid), "encounter_io_initialize_output nf90_def_dim space_dimid" ) ! 3D space dimension + call netcdf_check( nf90_def_dim(nc%id, nc%name_dimname, nc%name_dimsize, nc%name_dimid), "encounter_io_initialize_output nf90_def_dim name_dimid" ) ! dimension to store particle id numbers + call netcdf_check( nf90_def_dim(nc%id, nc%str_dimname, NAMELEN, nc%str_dimid), "encounter_io_initialize_output nf90_def_dim str_dimid" ) ! Dimension for string variables (aka character arrays) ! Dimension coordinates - call check( nf90_def_var(nc%id, nc%time_dimname, nc%out_type, nc%time_dimid, nc%time_varid), "encounter_io_initialize_output nf90_def_var time_varid" ) - call check( nf90_def_var(nc%id, nc%space_dimname, NF90_CHAR, nc%space_dimid, nc%space_varid), "encounter_io_initialize_output nf90_def_var space_varid" ) - call check( nf90_def_var(nc%id, nc%name_dimname, NF90_CHAR, [nc%str_dimid, nc%name_dimid], nc%name_varid), "encounter_io_initialize_output nf90_def_var id_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%time_dimname, nc%out_type, nc%time_dimid, nc%time_varid), "encounter_io_initialize_output nf90_def_var time_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%space_dimname, NF90_CHAR, nc%space_dimid, nc%space_varid), "encounter_io_initialize_output nf90_def_var space_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%name_dimname, NF90_CHAR, [nc%str_dimid, nc%name_dimid], nc%name_varid), "encounter_io_initialize_output nf90_def_var id_varid" ) ! Variables - call check( nf90_def_var(nc%id, nc%id_varname, NF90_INT, nc%name_dimid, nc%id_varid), "encounter_io_initialize_output nf90_def_var id_varid" ) - call check( nf90_def_var(nc%id, nc%ptype_varname, NF90_CHAR, [nc%str_dimid, nc%name_dimid], nc%ptype_varid), "encounter_io_initialize_output nf90_def_var ptype_varid" ) - call check( nf90_def_var(nc%id, nc%rh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%rh_varid), "encounter_io_initialize_output nf90_def_var rh_varid" ) - call check( nf90_def_var(nc%id, nc%vh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%vh_varid), "encounter_io_initialize_output nf90_def_var vh_varid" ) - call check( nf90_def_var(nc%id, nc%Gmass_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%Gmass_varid), "encounter_io_initialize_output nf90_def_var Gmass_varid" ) - call check( nf90_def_var(nc%id, nc%loop_varname, NF90_INT, [nc%time_dimid], nc%loop_varid), "encounter_io_initialize_output nf90_def_var loop_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%id_varname, NF90_INT, nc%name_dimid, nc%id_varid), "encounter_io_initialize_output nf90_def_var id_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%ptype_varname, NF90_CHAR, [nc%str_dimid, nc%name_dimid], nc%ptype_varid), "encounter_io_initialize_output nf90_def_var ptype_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%rh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%rh_varid), "encounter_io_initialize_output nf90_def_var rh_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%vh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%vh_varid), "encounter_io_initialize_output nf90_def_var vh_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%Gmass_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%Gmass_varid), "encounter_io_initialize_output nf90_def_var Gmass_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%loop_varname, NF90_INT, [nc%time_dimid], nc%loop_varid), "encounter_io_initialize_output nf90_def_var loop_varid" ) if (param%lclose) then - call check( nf90_def_var(nc%id, nc%radius_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%radius_varid), "encounter_io_initialize_output nf90_def_var radius_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%radius_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%radius_varid), "encounter_io_initialize_output nf90_def_var radius_varid" ) end if if (param%lrotation) then - call check( nf90_def_var(nc%id, nc%Ip_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%Ip_varid), "encounter_io_initialize_output nf90_def_var Ip_varid" ) - call check( nf90_def_var(nc%id, nc%rot_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%rot_varid), "encounter_io_initialize_output nf90_def_var rot_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%Ip_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%Ip_varid), "encounter_io_initialize_output nf90_def_var Ip_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%rot_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%rot_varid), "encounter_io_initialize_output nf90_def_var rot_varid" ) end if - call check( nf90_inquire(nc%id, nVariables=nvar), "encounter_io_initialize_output nf90_inquire nVariables" ) + call netcdf_check( nf90_inquire(nc%id, nVariables=nvar), "encounter_io_initialize_output nf90_inquire nVariables" ) do varid = 1, nvar - call check( nf90_inquire_variable(nc%id, varid, xtype=vartype, ndims=ndims), "encounter_io_initialize_output nf90_inquire_variable" ) + call netcdf_check( nf90_inquire_variable(nc%id, varid, xtype=vartype, ndims=ndims), "encounter_io_initialize_output nf90_inquire_variable" ) select case(vartype) case(NF90_INT) - call check( nf90_def_var_fill(nc%id, varid, NO_FILL, NF90_FILL_INT), "encounter_io_initialize_output nf90_def_var_fill NF90_INT" ) + call netcdf_check( nf90_def_var_fill(nc%id, varid, NO_FILL, NF90_FILL_INT), "encounter_io_initialize_output nf90_def_var_fill NF90_INT" ) case(NF90_FLOAT) - call check( nf90_def_var_fill(nc%id, varid, NO_FILL, sfill), "encounter_io_initialize_output nf90_def_var_fill NF90_FLOAT" ) + call netcdf_check( nf90_def_var_fill(nc%id, varid, NO_FILL, sfill), "encounter_io_initialize_output nf90_def_var_fill NF90_FLOAT" ) case(NF90_DOUBLE) - call check( nf90_def_var_fill(nc%id, varid, NO_FILL, dfill), "encounter_io_initialize_output nf90_def_var_fill NF90_DOUBLE" ) + call netcdf_check( nf90_def_var_fill(nc%id, varid, NO_FILL, dfill), "encounter_io_initialize_output nf90_def_var_fill NF90_DOUBLE" ) case(NF90_CHAR) - call check( nf90_def_var_fill(nc%id, varid, NO_FILL, 0), "encounter_io_initialize_output nf90_def_var_fill NF90_CHAR" ) + call netcdf_check( nf90_def_var_fill(nc%id, varid, NO_FILL, 0), "encounter_io_initialize_output nf90_def_var_fill NF90_CHAR" ) end select end do ! Take the file out of define mode - call check( nf90_enddef(nc%id), "encounter_io_initialize_output nf90_enddef" ) + call netcdf_check( nf90_enddef(nc%id), "encounter_io_initialize_output nf90_enddef" ) ! Add in the space dimension coordinates - call check( nf90_put_var(nc%id, nc%space_varid, nc%space_coords, start=[1], count=[NDIM]), "encounter_io_initialize_output nf90_put_var space" ) + call netcdf_check( nf90_put_var(nc%id, nc%space_varid, nc%space_coords, start=[1], count=[NDIM]), "encounter_io_initialize_output nf90_put_var space" ) end associate @@ -150,67 +150,74 @@ module subroutine encounter_io_initialize_output(self, param) end subroutine encounter_io_initialize_output - module subroutine encounter_io_write_frame_snapshot(self, nc, param) + module subroutine encounter_io_write_frame_snapshot(self, history, param) !! author: David A. Minton !! !! Write a frame of output of an encounter trajectory. use netcdf implicit none ! Arguments - class(encounter_snapshot), intent(in) :: self !! Swiftest encounter structure - class(netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular encounter io NetCDF dataset - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(encounter_snapshot), intent(in) :: self !! Swiftest encounter structure + class(encounter_storage(*)), intent(inout) :: history !! Encounter storage object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + ! Internals integer(I4B) :: i, idslot, old_mode, npl, ntp character(len=:), allocatable :: charstring - select type (nc) + select type(param) + class is (swiftest_parameters) + select type(pl => self%pl) + class is (swiftest_pl) + select type(tp => self%tp) + class is (swiftest_pl) + select type (nc => history%nc) class is (encounter_io_parameters) - select type (param) - class is (symba_parameters) - associate(pl => self%pl, tp => self%tp, encounter_history => param%encounter_history, tslot => param%ioutput) - call check( nf90_set_fill(nc%id, nf90_nofill, old_mode), "encounter_io_write_frame_snapshot nf90_set_fill" ) - - call check( nf90_put_var(nc%id, nc%time_varid, self%t, start=[tslot]), "encounter_io_write_frame_snapshot nf90_put_var time_varid" ) - call check( nf90_put_var(nc%id, nc%loop_varid, int(self%iloop,kind=I4B), start=[tslot]), "encounter_io_write_frame_snapshot nf90_put_var pl loop_varid" ) - - npl = pl%nbody - do i = 1, npl - idslot = findloc(encounter_history%idvals,pl%id(i),dim=1) - call check( nf90_put_var(nc%id, nc%id_varid, pl%id(i), start=[idslot]), "encounter_io_write_frame_snapshot nf90_put_var pl id_varid" ) - call check( nf90_put_var(nc%id, nc%rh_varid, pl%rh(:,i), start=[1,idslot,tslot], count=[NDIM,1,1]), "encounter_io_write_frame_snapshot nf90_put_var pl rh_varid" ) - call check( nf90_put_var(nc%id, nc%vh_varid, pl%vh(:,i), start=[1,idslot,tslot], count=[NDIM,1,1]), "encounter_io_write_frame_snapshot nf90_put_var pl vh_varid" ) - call check( nf90_put_var(nc%id, nc%Gmass_varid, pl%Gmass(i), start=[idslot, tslot]), "encounter_io_write_frame_snapshot nf90_put_var pl Gmass_varid" ) - - if (param%lclose) call check( nf90_put_var(nc%id, nc%radius_varid, pl%radius(i), start=[idslot, tslot]), "encounter_io_write_frame_snapshot nf90_put_var pl radius_varid" ) - - if (param%lrotation) then - call check( nf90_put_var(nc%id, nc%Ip_varid, pl%Ip(:,i), start=[1, idslot, tslot], count=[NDIM,1,1]), "encounter_io_write_frame_snapshot nf90_put_var pl Ip_varid" ) - call check( nf90_put_var(nc%id, nc%rot_varid, pl%rot(:,i), start=[1,idslot, tslot], count=[NDIM,1,1]), "encounter_io_write_frame_snapshot nf90_put_var pl rotx_varid" ) - end if - - charstring = trim(adjustl(pl%info(i)%name)) - call check( nf90_put_var(nc%id, nc%name_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "encounter_io_write_frame_snapshot nf90_put_var pl name_varid" ) - charstring = trim(adjustl(pl%info(i)%particle_type)) - call check( nf90_put_var(nc%id, nc%ptype_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "encounter_io_write_frame_snapshot nf90_put_var pl particle_type_varid" ) - end do - - ntp = tp%nbody - do i = 1, ntp - idslot = findloc(param%encounter_history%idvals,tp%id(i),dim=1) - call check( nf90_put_var(nc%id, nc%id_varid, tp%id(i), start=[idslot]), "encounter_io_write_frame_snapshot nf90_put_var tp id_varid" ) - call check( nf90_put_var(nc%id, nc%rh_varid, tp%rh(:,i), start=[1,idslot,tslot], count=[NDIM,1,1]), "encounter_io_write_frame_snapshot nf90_put_var tp rh_varid" ) - call check( nf90_put_var(nc%id, nc%vh_varid, tp%vh(:,i), start=[1,idslot,tslot], count=[NDIM,1,1]), "encounter_io_write_frame_snapshot nf90_put_var tp vh_varid" ) - - charstring = trim(adjustl(tp%info(i)%name)) - call check( nf90_put_var(nc%id, nc%name_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "encounter_io_write_frame_snapshot nf90_put_var tp name_varid" ) - charstring = trim(adjustl(tp%info(i)%particle_type)) - call check( nf90_put_var(nc%id, nc%ptype_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "encounter_io_write_frame_snapshot nf90_put_var tp particle_type_varid" ) - end do - - call check( nf90_set_fill(nc%id, old_mode, old_mode) ) - end associate - end select + associate(tslot => param%ioutput) + call netcdf_check( nf90_set_fill(nc%id, nf90_nofill, old_mode), "encounter_io_write_frame_snapshot nf90_set_fill" ) + + call netcdf_check( nf90_put_var(nc%id, nc%time_varid, self%t, start=[tslot]), "encounter_io_write_frame_snapshot nf90_put_var time_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%loop_varid, int(self%iloop,kind=I4B), start=[tslot]), "encounter_io_write_frame_snapshot nf90_put_var pl loop_varid" ) + + npl = pl%nbody + do i = 1, npl + idslot = findloc(history%idvals,pl%id(i),dim=1) + call netcdf_check( nf90_put_var(nc%id, nc%id_varid, pl%id(i), start=[idslot]), "encounter_io_write_frame_snapshot nf90_put_var pl id_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%rh_varid, pl%rh(:,i), start=[1,idslot,tslot], count=[NDIM,1,1]), "encounter_io_write_frame_snapshot nf90_put_var pl rh_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%vh_varid, pl%vh(:,i), start=[1,idslot,tslot], count=[NDIM,1,1]), "encounter_io_write_frame_snapshot nf90_put_var pl vh_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%Gmass_varid, pl%Gmass(i), start=[idslot, tslot]), "encounter_io_write_frame_snapshot nf90_put_var pl Gmass_varid" ) + + if (param%lclose) call netcdf_check( nf90_put_var(nc%id, nc%radius_varid, pl%radius(i), start=[idslot, tslot]), "encounter_io_write_frame_snapshot nf90_put_var pl radius_varid" ) + + if (param%lrotation) then + call netcdf_check( nf90_put_var(nc%id, nc%Ip_varid, pl%Ip(:,i), start=[1, idslot, tslot], count=[NDIM,1,1]), "encounter_io_write_frame_snapshot nf90_put_var pl Ip_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%rot_varid, pl%rot(:,i), start=[1,idslot, tslot], count=[NDIM,1,1]), "encounter_io_write_frame_snapshot nf90_put_var pl rotx_varid" ) + end if + + charstring = trim(adjustl(pl%info(i)%name)) + call netcdf_check( nf90_put_var(nc%id, nc%name_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "encounter_io_write_frame_snapshot nf90_put_var pl name_varid" ) + charstring = trim(adjustl(pl%info(i)%particle_type)) + call netcdf_check( nf90_put_var(nc%id, nc%ptype_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "encounter_io_write_frame_snapshot nf90_put_var pl particle_type_varid" ) + end do + + ntp = tp%nbody + do i = 1, ntp + idslot = findloc(history%idvals,tp%id(i),dim=1) + call netcdf_check( nf90_put_var(nc%id, nc%id_varid, tp%id(i), start=[idslot]), "encounter_io_write_frame_snapshot nf90_put_var tp id_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%rh_varid, tp%rh(:,i), start=[1,idslot,tslot], count=[NDIM,1,1]), "encounter_io_write_frame_snapshot nf90_put_var tp rh_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%vh_varid, tp%vh(:,i), start=[1,idslot,tslot], count=[NDIM,1,1]), "encounter_io_write_frame_snapshot nf90_put_var tp vh_varid" ) + + charstring = trim(adjustl(tp%info(i)%name)) + call netcdf_check( nf90_put_var(nc%id, nc%name_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "encounter_io_write_frame_snapshot nf90_put_var tp name_varid" ) + charstring = trim(adjustl(tp%info(i)%particle_type)) + call netcdf_check( nf90_put_var(nc%id, nc%ptype_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "encounter_io_write_frame_snapshot nf90_put_var tp particle_type_varid" ) + end do + + call netcdf_check( nf90_set_fill(nc%id, old_mode, old_mode) ) + end associate + end select + end select + end select end select return diff --git a/src/encounter/encounter_setup.f90 b/src/encounter/encounter_setup.f90 index 18b60d229..aff1bd626 100644 --- a/src/encounter/encounter_setup.f90 +++ b/src/encounter/encounter_setup.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule (encounter_classes) s_encounter_setup +submodule (encounter) s_encounter_setup use swiftest contains @@ -72,6 +72,7 @@ module subroutine encounter_setup_list(self, n) if (n == 0_I8B) return self%t = 0.0_DP + allocate(self%tcollision(n)) allocate(self%lvdotr(n)) allocate(self%lclosest(n)) allocate(self%status(n)) @@ -84,6 +85,7 @@ module subroutine encounter_setup_list(self, n) allocate(self%v1(NDIM,n)) allocate(self%v2(NDIM,n)) + self%tcollision(:) = 0.0_DP self%lvdotr(:) = .false. self%lclosest(:) = .false. self%status(:) = INACTIVE diff --git a/src/encounter/encounter_util.f90 b/src/encounter/encounter_util.f90 index 4c472c4b3..8dc63201e 100644 --- a/src/encounter/encounter_util.f90 +++ b/src/encounter/encounter_util.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule (encounter_classes) s_encounter_util +submodule (encounter) s_encounter_util use swiftest contains @@ -96,6 +96,7 @@ module subroutine encounter_util_dealloc_list(self) ! Arguments class(encounter_list), intent(inout) :: self + if (allocated(self%tcollision)) deallocate(self%tcollision) if (allocated(self%lvdotr)) deallocate(self%lvdotr) if (allocated(self%lclosest)) deallocate(self%lclosest) if (allocated(self%status)) deallocate(self%status) @@ -126,20 +127,6 @@ module subroutine encounter_util_final_aabb(self) end subroutine encounter_util_final_aabb - module subroutine encounter_util_final_list(self) - !! author: David A. Minton - !! - !! Finalize the encounter list - deallocates all allocatables - implicit none - ! Arguments - type(encounter_list), intent(inout) :: self - - call self%dealloc() - - return - end subroutine encounter_util_final_list - - module subroutine encounter_util_final_snapshot(self) !! author: David A. Minton !! @@ -163,8 +150,14 @@ module subroutine encounter_util_final_storage(self) implicit none ! Arguments type(encounter_storage(*)), intent(inout) :: self !! Encounter storage object + ! Internals + integer(I4B) :: i + + do i = 1, self%nframes + if (allocated(self%frame(i)%item)) deallocate(self%frame(i)%item) + end do - call util_final_storage(self%swiftest_storage) + return return end subroutine encounter_util_final_storage @@ -181,22 +174,29 @@ module subroutine encounter_util_get_idvalues_snapshot(self, idvals) ! Internals integer(I4B) :: npl, ntp - if (allocated(self%pl)) then - npl = self%pl%nbody - else - npl = 0 - end if - if (allocated(self%tp)) then - ntp = self%tp%nbody - else - ntp = 0 - end if + select type(pl => self%pl) + class is (swiftest_pl) + select type(tp => self%tp) + class is (swiftest_tp) + if (allocated(self%pl)) then + npl = pl%nbody + else + npl = 0 + end if + + if (allocated(self%tp)) then + ntp = tp%nbody + else + ntp = 0 + end if - if (npl + ntp == 0) return - allocate(idvals(npl+ntp)) + if (npl + ntp == 0) return + allocate(idvals(npl+ntp)) - if (npl > 0) idvals(1:npl) = self%pl%id(:) - if (ntp >0) idvals(npl+1:npl+ntp) = self%tp%id(:) + if (npl > 0) idvals(1:npl) = pl%id(:) + if (ntp >0) idvals(npl+1:npl+ntp) = tp%id(:) + end select + end select return @@ -372,7 +372,7 @@ subroutine encounter_util_save_snapshot(encounter_history, snapshot) !! Memory usage grows by a factor of 2 each time it fills up, but no more. implicit none ! Arguments - type(encounter_storage(*)), allocatable, intent(inout) :: encounter_history !! SyMBA encounter storage object + class(encounter_storage(*)), allocatable, intent(inout) :: encounter_history !! SyMBA encounter storage object class(encounter_snapshot), intent(in) :: snapshot !! Encounter snapshot object ! Internals type(encounter_storage(nframes=:)), allocatable :: tmp @@ -415,11 +415,12 @@ module subroutine encounter_util_snapshot(self, param, system, t, arg) !! !! Takes a minimal snapshot of the state of the system during an encounter so that the trajectories !! can be played back through the encounter + use symba implicit none ! Internals class(encounter_storage(*)), intent(inout) :: self !! Swiftest storage object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object to store + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + class(base_nbody_system), intent(inout) :: system !! Swiftest nbody system object to store real(DP), intent(in), optional :: t !! Time of snapshot if different from system time character(*), intent(in), optional :: arg !! Optional argument (needed for extended storage type used in collision snapshots) ! Arguments @@ -440,164 +441,194 @@ module subroutine encounter_util_snapshot(self, param, system, t, arg) end if select type(param) - class is (symba_parameters) - select type (system) - class is (symba_nbody_system) - select type(pl => system%pl) - class is (symba_pl) - select type (tp => system%tp) - class is (symba_tp) - associate(npl => pl%nbody, ntp => tp%nbody) - if (npl + ntp == 0) return - allocate(encounter_snapshot :: snapshot) - allocate(snapshot%pl, mold=pl) - allocate(snapshot%tp, mold=tp) - snapshot%iloop = param%iloop - - select type(pl_snap => snapshot%pl) - class is (symba_pl) - select type(tp_snap => snapshot%tp) + class is (swiftest_parameters) + select type (system) + class is (swiftest_nbody_system) + select type (pl => system%pl) + class is (swiftest_pl) + select type (tp => system%tp) + class is (swiftest_tp) + associate(npl => pl%nbody, ntp => tp%nbody) + if (npl + ntp == 0) return + allocate(encounter_snapshot :: snapshot) + allocate(snapshot%pl, mold=pl) + allocate(snapshot%tp, mold=tp) + snapshot%iloop = param%iloop + + select type(pl_snap => snapshot%pl) + class is (swiftest_pl) + select type(tp_snap => snapshot%tp) + class is (swiftest_tp) + + select case(arg) + case("trajectory") + snapshot%t = t + + npl_snap = npl + ntp_snap = ntp + + if (npl > 0) then + pl%lmask(1:npl) = pl%status(1:npl) /= INACTIVE + select type(pl) + class is (symba_pl) + select type(system) + class is (symba_nbody_system) + pl%lmask(1:npl) = pl%lmask(1:npl) .and. pl%levelg(1:npl) == system%irec + end select + end select + npl_snap = count(pl%lmask(1:npl)) + end if + if (ntp > 0) then + tp%lmask(1:ntp) = tp%status(1:ntp) /= INACTIVE + select type(tp) class is (symba_tp) + select type(system) + class is (symba_nbody_system) + tp%lmask(1:ntp) = tp%lmask(1:ntp) .and. tp%levelg(1:ntp) == system%irec + end select + end select + ntp_snap = count(tp%lmask(1:ntp)) + end if - select case(arg) - case("trajectory") - snapshot%t = t - - npl_snap = npl - ntp_snap = ntp - - if (npl > 0) then - pl%lmask(1:npl) = pl%status(1:npl) /= INACTIVE .and. pl%levelg(1:npl) == system%irec - npl_snap = count(pl%lmask(1:npl)) - end if - if (ntp > 0) then - tp%lmask(1:ntp) = tp%status(1:ntp) /= INACTIVE .and. tp%levelg(1:ntp) == system%irec - ntp_snap = count(tp%lmask(1:ntp)) - end if + if (npl_snap + ntp_snap == 0) return ! Nothing to snapshot - if (npl_snap + ntp_snap == 0) return ! Nothing to snapshot - - pl_snap%nbody = npl_snap - - ! Take snapshot of the currently encountering massive bodies - if (npl_snap > 0) then - call pl_snap%setup(npl_snap, param) - pl_snap%levelg(:) = pack(pl%levelg(1:npl), pl%lmask(1:npl)) - pl_snap%id(:) = pack(pl%id(1:npl), pl%lmask(1:npl)) - pl_snap%info(:) = pack(pl%info(1:npl), pl%lmask(1:npl)) - pl_snap%Gmass(:) = pack(pl%Gmass(1:npl), pl%lmask(1:npl)) - do i = 1, NDIM - pl_snap%rh(i,:) = pack(pl%rh(i,1:npl), pl%lmask(1:npl)) - pl_snap%vh(i,:) = pack(pl%vb(i,1:npl), pl%lmask(1:npl)) - end do - if (param%lclose) then - pl_snap%radius(:) = pack(pl%radius(1:npl), pl%lmask(1:npl)) - end if + pl_snap%nbody = npl_snap + + ! Take snapshot of the currently encountering massive bodies + if (npl_snap > 0) then + call pl_snap%setup(npl_snap, param) + select type (pl) + class is (symba_pl) + select type(pl_snap) + class is (symba_pl) + pl_snap%levelg(:) = pack(pl%levelg(1:npl), pl%lmask(1:npl)) + end select + end select + pl_snap%id(:) = pack(pl%id(1:npl), pl%lmask(1:npl)) + pl_snap%info(:) = pack(pl%info(1:npl), pl%lmask(1:npl)) + pl_snap%Gmass(:) = pack(pl%Gmass(1:npl), pl%lmask(1:npl)) + do i = 1, NDIM + pl_snap%rh(i,:) = pack(pl%rh(i,1:npl), pl%lmask(1:npl)) + pl_snap%vh(i,:) = pack(pl%vb(i,1:npl), pl%lmask(1:npl)) + end do + if (param%lclose) then + pl_snap%radius(:) = pack(pl%radius(1:npl), pl%lmask(1:npl)) + end if + + if (param%lrotation) then + do i = 1, NDIM + pl_snap%Ip(i,:) = pack(pl%Ip(i,1:npl), pl%lmask(1:npl)) + pl_snap%rot(i,:) = pack(pl%rot(i,1:npl), pl%lmask(1:npl)) + end do + end if + call pl_snap%sort("id", ascending=.true.) + end if + + ! Take snapshot of the currently encountering test particles + tp_snap%nbody = ntp_snap + if (ntp_snap > 0) then + call tp_snap%setup(ntp_snap, param) + tp_snap%id(:) = pack(tp%id(1:ntp), tp%lmask(1:ntp)) + tp_snap%info(:) = pack(tp%info(1:ntp), tp%lmask(1:ntp)) + do i = 1, NDIM + tp_snap%rh(i,:) = pack(tp%rh(i,1:ntp), tp%lmask(1:ntp)) + tp_snap%vh(i,:) = pack(tp%vh(i,1:ntp), tp%lmask(1:ntp)) + end do + end if + + ! Save the snapshot + select type (encounter_history => system%encounter_history) + class is (encounter_storage(*)) + encounter_history%nid = encounter_history%nid + ntp_snap + npl_snap + call encounter_util_save_snapshot(system%encounter_history,snapshot) + end select + case("closest") + associate(plpl_encounter => system%plpl_encounter, pltp_encounter => system%pltp_encounter) + if (any(plpl_encounter%lclosest(:))) then + call pl_snap%setup(2, param) + do k = 1, plpl_encounter%nenc + if (plpl_encounter%lclosest(k)) then + pi = plpl_encounter%index1(k) + pj = plpl_encounter%index2(k) + select type(pl_snap) + class is (symba_pl) + select type(pl) + class is (symba_pl) + pl_snap%levelg(:) = pl%levelg([pi,pj]) + end select + end select + pl_snap%id(:) = pl%id([pi,pj]) + pl_snap%info(:) = pl%info([pi,pj]) + pl_snap%Gmass(:) = pl%Gmass([pi,pj]) + Gmtot = sum(pl_snap%Gmass(:)) + if (param%lclose) pl_snap%radius(:) = pl%radius([pi,pj]) if (param%lrotation) then do i = 1, NDIM - pl_snap%Ip(i,:) = pack(pl%Ip(i,1:npl), pl%lmask(1:npl)) - pl_snap%rot(i,:) = pack(pl%rot(i,1:npl), pl%lmask(1:npl)) + pl_snap%Ip(i,:) = pl%Ip(i,[pi,pj]) + pl_snap%rot(i,:) = pl%rot(i,[pi,pj]) end do end if - call pl_snap%sort("id", ascending=.true.) - end if - - ! Take snapshot of the currently encountering test particles - tp_snap%nbody = ntp_snap - if (ntp_snap > 0) then - call tp_snap%setup(ntp_snap, param) - tp_snap%id(:) = pack(tp%id(1:ntp), tp%lmask(1:ntp)) - tp_snap%info(:) = pack(tp%info(1:ntp), tp%lmask(1:ntp)) - do i = 1, NDIM - tp_snap%rh(i,:) = pack(tp%rh(i,1:ntp), tp%lmask(1:ntp)) - tp_snap%vh(i,:) = pack(tp%vh(i,1:ntp), tp%lmask(1:ntp)) - end do - end if - - ! Save the snapshot - param%encounter_history%nid = param%encounter_history%nid + ntp_snap + npl_snap - call encounter_util_save_snapshot(param%encounter_history,snapshot) - case("closest") - associate(plplenc_list => system%plplenc_list, pltpenc_list => system%pltpenc_list) - if (any(plplenc_list%lclosest(:))) then - call pl_snap%setup(2, param) - do k = 1, plplenc_list%nenc - if (plplenc_list%lclosest(k)) then - pi = plplenc_list%index1(k) - pj = plplenc_list%index2(k) - pl_snap%levelg(:) = pl%levelg([pi,pj]) - pl_snap%id(:) = pl%id([pi,pj]) - pl_snap%info(:) = pl%info([pi,pj]) - pl_snap%Gmass(:) = pl%Gmass([pi,pj]) - Gmtot = sum(pl_snap%Gmass(:)) - if (param%lclose) pl_snap%radius(:) = pl%radius([pi,pj]) - if (param%lrotation) then - do i = 1, NDIM - pl_snap%Ip(i,:) = pl%Ip(i,[pi,pj]) - pl_snap%rot(i,:) = pl%rot(i,[pi,pj]) - end do - end if - - ! Compute pericenter passage time to get the closest approach parameters - rrel(:) = plplenc_list%r2(:,k) - plplenc_list%r1(:,k) - vrel(:) = plplenc_list%v2(:,k) - plplenc_list%v1(:,k) - call orbel_xv2aqt(Gmtot, rrel(1), rrel(2), rrel(3), vrel(1), vrel(2), vrel(3), a, q, capm, tperi) - snapshot%t = t + tperi - if ((snapshot%t < maxval(pl_snap%info(:)%origin_time)) .or. & - (snapshot%t > minval(pl_snap%info(:)%discard_time))) cycle - - ! Computer the center mass of the pair - rcom(:) = (plplenc_list%r1(:,k) * pl_snap%Gmass(1) + plplenc_list%r2(:,k) * pl_snap%Gmass(2)) / Gmtot - vcom(:) = (plplenc_list%v1(:,k) * pl_snap%Gmass(1) + plplenc_list%v2(:,k) * pl_snap%Gmass(2)) / Gmtot - rb(:,1) = plplenc_list%r1(:,k) - rcom(:) - rb(:,2) = plplenc_list%r2(:,k) - rcom(:) - vb(:,1) = plplenc_list%v1(:,k) - vcom(:) - vb(:,2) = plplenc_list%v2(:,k) - vcom(:) - - ! Drift the relative orbit to get the new relative position and velocity - call drift_one(Gmtot, rrel(1), rrel(2), rrel(3), vrel(1), vrel(2), vrel(3), tperi, iflag) - if (iflag /= 0) write(*,*) "Danby error in encounter_util_snapshot_encounter. Closest approach positions and vectors may not be accurate." - - ! Get the new position and velocity vectors - rb(:,1) = -(pl_snap%Gmass(2) / Gmtot) * rrel(:) - rb(:,2) = (pl_snap%Gmass(1)) / Gmtot * rrel(:) - - vb(:,1) = -(pl_snap%Gmass(2) / Gmtot) * vrel(:) - vb(:,2) = (pl_snap%Gmass(1)) / Gmtot * vrel(:) - - ! Move the CoM assuming constant velocity over the time it takes to reach periapsis - rcom(:) = rcom(:) + vcom(:) * tperi - - ! Compute the heliocentric position and velocity vector at periapsis - pl_snap%rh(:,1) = rb(:,1) + rcom(:) - pl_snap%rh(:,2) = rb(:,2) + rcom(:) - pl_snap%vh(:,1) = vb(:,1) + vcom(:) - pl_snap%vh(:,2) = vb(:,2) + vcom(:) - - call pl_snap%sort("id", ascending=.true.) - call encounter_util_save_snapshot(param%encounter_history,snapshot) - end if - end do - plplenc_list%lclosest(:) = .false. - end if + ! Compute pericenter passage time to get the closest approach parameters + rrel(:) = plpl_encounter%r2(:,k) - plpl_encounter%r1(:,k) + vrel(:) = plpl_encounter%v2(:,k) - plpl_encounter%v1(:,k) + call swiftest_orbel_xv2aqt(Gmtot, rrel(1), rrel(2), rrel(3), vrel(1), vrel(2), vrel(3), a, q, capm, tperi) + snapshot%t = t + tperi + if ((snapshot%t < maxval(pl_snap%info(:)%origin_time)) .or. & + (snapshot%t > minval(pl_snap%info(:)%discard_time))) cycle + + ! Computer the center mass of the pair + rcom(:) = (plpl_encounter%r1(:,k) * pl_snap%Gmass(1) + plpl_encounter%r2(:,k) * pl_snap%Gmass(2)) / Gmtot + vcom(:) = (plpl_encounter%v1(:,k) * pl_snap%Gmass(1) + plpl_encounter%v2(:,k) * pl_snap%Gmass(2)) / Gmtot + rb(:,1) = plpl_encounter%r1(:,k) - rcom(:) + rb(:,2) = plpl_encounter%r2(:,k) - rcom(:) + vb(:,1) = plpl_encounter%v1(:,k) - vcom(:) + vb(:,2) = plpl_encounter%v2(:,k) - vcom(:) + + ! Drift the relative orbit to get the new relative position and velocity + call swiftest_drift_one(Gmtot, rrel(1), rrel(2), rrel(3), vrel(1), vrel(2), vrel(3), tperi, iflag) + if (iflag /= 0) write(*,*) "Danby error in encounter_util_snapshot_encounter. Closest approach positions and vectors may not be accurate." + + ! Get the new position and velocity vectors + rb(:,1) = -(pl_snap%Gmass(2) / Gmtot) * rrel(:) + rb(:,2) = (pl_snap%Gmass(1)) / Gmtot * rrel(:) + + vb(:,1) = -(pl_snap%Gmass(2) / Gmtot) * vrel(:) + vb(:,2) = (pl_snap%Gmass(1)) / Gmtot * vrel(:) + + ! Move the CoM assuming constant velocity over the time it takes to reach periapsis + rcom(:) = rcom(:) + vcom(:) * tperi + + ! Compute the heliocentric position and velocity vector at periapsis + pl_snap%rh(:,1) = rb(:,1) + rcom(:) + pl_snap%rh(:,2) = rb(:,2) + rcom(:) + pl_snap%vh(:,1) = vb(:,1) + vcom(:) + pl_snap%vh(:,2) = vb(:,2) + vcom(:) - if (any(pltpenc_list%lclosest(:))) then - do k = 1, pltpenc_list%nenc - end do - pltpenc_list%lclosest(:) = .false. - end if - end associate - case default - write(*,*) "encounter_util_snapshot_encounter requires `arg` to be either `trajectory` or `closest`" - end select - end select - end select - end associate + call pl_snap%sort("id", ascending=.true.) + call encounter_util_save_snapshot(system%encounter_history,snapshot) + end if + end do + + plpl_encounter%lclosest(:) = .false. + end if + + if (any(pltp_encounter%lclosest(:))) then + do k = 1, pltp_encounter%nenc + end do + pltp_encounter%lclosest(:) = .false. + end if + end associate + case default + write(*,*) "encounter_util_snapshot_encounter requires `arg` to be either `trajectory` or `closest`" + end select end select end select - end select + end associate + end select + end select + end select end select return diff --git a/src/fraggle/fraggle_generate.f90 b/src/fraggle/fraggle_generate.f90 index 67b375940..5f9eccee8 100644 --- a/src/fraggle/fraggle_generate.f90 +++ b/src/fraggle/fraggle_generate.f90 @@ -7,8 +7,9 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(fraggle_classes) s_fraggle_generate +submodule(fraggle) s_fraggle_generate use swiftest + use symba integer(I4B), parameter :: NFRAG_MIN = 7 !! The minimum allowable number of fragments (set to 6 because that's how many unknowns are needed in the tangential velocity calculation) real(DP), parameter :: F_SPIN_FIRST = 0.05_DP !! The initial try value of the fraction of energy or momenum in spin (whichever has the lowest kinetic energy) @@ -24,10 +25,10 @@ module subroutine fraggle_generate_fragments(self, system, param, lfailure) use, intrinsic :: ieee_exceptions implicit none ! Arguments - class(fraggle_system), intent(inout) :: self !! Fraggle system object the outputs will be the fragmentation - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - logical, intent(out) :: lfailure !! Answers the question: Should this have been a merger instead? + class(fraggle_system), intent(inout) :: self !! Fraggle system object the outputs will be the fragmentation + class(base_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + logical, intent(out) :: lfailure !! Answers the question: Should this have been a merger instead? ! Internals integer(I4B) :: i integer(I4B) :: try @@ -45,15 +46,19 @@ module subroutine fraggle_generate_fragments(self, system, param, lfailure) fpe_quiet_modes(:) = .false. call ieee_set_halting_mode(IEEE_ALL,fpe_quiet_modes) + select type(system) + class is (swiftest_nbody_system) + select type(param) + class is (swiftest_parameters) select type(fragments => self%fragments) - class is (fraggle_fragments) + class is (fraggle_fragments(*)) associate(collision_system => self, impactors => self%impactors, nfrag => fragments%nbody, pl => system%pl) write(message,*) nfrag - call io_log_one_message(FRAGGLE_LOG_OUT, "Fraggle generating " // trim(adjustl(message)) // " fragments.") + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "Fraggle generating " // trim(adjustl(message)) // " fragments.") if (nfrag < NFRAG_MIN) then write(message,*) "Fraggle needs at least ",NFRAG_MIN," fragments, but only ",nfrag," were given." - call io_log_one_message(FRAGGLE_LOG_OUT, message) + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, message) lfailure = .true. return end if @@ -82,7 +87,7 @@ module subroutine fraggle_generate_fragments(self, system, param, lfailure) try = 1 do while (try < MAXTRY) write(message,*) try - call io_log_one_message(FRAGGLE_LOG_OUT, "Fraggle try " // trim(adjustl(message))) + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "Fraggle try " // trim(adjustl(message))) if (lfailure) then call fragments%restructure(impactors, try, f_spin, r_max_start) call fragments%reset() @@ -105,19 +110,19 @@ module subroutine fraggle_generate_fragments(self, system, param, lfailure) call fraggle_generate_spins(collision_system, f_spin, lfailure) if (lfailure) then - call io_log_one_message(FRAGGLE_LOG_OUT, "Fraggle failed to find spins") + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "Fraggle failed to find spins") cycle end if call fraggle_generate_tan_vel(collision_system, lfailure) if (lfailure) then - call io_log_one_message(FRAGGLE_LOG_OUT, "Fraggle failed to find tangential velocities") + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "Fraggle failed to find tangential velocities") cycle end if call fraggle_generate_rad_vel(collision_system, lfailure) if (lfailure) then - call io_log_one_message(FRAGGLE_LOG_OUT, "Fraggle failed to find radial velocities") + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "Fraggle failed to find radial velocities") cycle end if @@ -129,7 +134,7 @@ module subroutine fraggle_generate_fragments(self, system, param, lfailure) lfailure = ((abs(dEtot + impactors%Qloss) > FRAGGLE_ETOL) .or. (dEtot > 0.0_DP)) if (lfailure) then write(message, *) dEtot, abs(dEtot + impactors%Qloss) / FRAGGLE_ETOL - call io_log_one_message(FRAGGLE_LOG_OUT, "Fraggle failed due to high energy error: " // & + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "Fraggle failed due to high energy error: " // & trim(adjustl(message))) cycle end if @@ -137,7 +142,7 @@ module subroutine fraggle_generate_fragments(self, system, param, lfailure) lfailure = ((abs(dLmag) / (.mag.collision_system%Ltot(:,1))) > FRAGGLE_LTOL) if (lfailure) then write(message,*) dLmag / (.mag.collision_system%Ltot(:,1)) - call io_log_one_message(FRAGGLE_LOG_OUT, "Fraggle failed due to high angular momentum error: " // & + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "Fraggle failed due to high angular momentum error: " // & trim(adjustl(message))) cycle end if @@ -147,15 +152,15 @@ module subroutine fraggle_generate_fragments(self, system, param, lfailure) lfailure = any(fpe_flag) if (.not.lfailure) exit write(message,*) "Fraggle failed due to a floating point exception: ", fpe_flag - call io_log_one_message(FRAGGLE_LOG_OUT, message) + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, message) end do write(message,*) try if (lfailure) then - call io_log_one_message(FRAGGLE_LOG_OUT, "Fraggle fragment generation failed after " // & + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "Fraggle fragment generation failed after " // & trim(adjustl(message)) // " tries") else - call io_log_one_message(FRAGGLE_LOG_OUT, "Fraggle fragment generation succeeded after " // & + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "Fraggle fragment generation succeeded after " // & trim(adjustl(message)) // " tries") end if @@ -165,6 +170,8 @@ module subroutine fraggle_generate_fragments(self, system, param, lfailure) if (lk_plpl) call pl%flatten(param) end associate end select + end select + end select call ieee_set_halting_mode(IEEE_ALL,fpe_halting_modes) ! Save the current halting modes so we can turn them off temporarily return @@ -275,7 +282,7 @@ subroutine fraggle_generate_spins(collision_system, f_spin, lfailure) associate(impactors => collision_system%impactors, nfrag => collision_system%fragments%nbody) select type(fragments => collision_system%fragments) - class is (fraggle_fragments) + class is (fraggle_fragments(*)) lfailure = .false. L_remainder(:) = fragments%L_budget(:) ke_remainder = fragments%ke_budget @@ -325,16 +332,16 @@ subroutine fraggle_generate_spins(collision_system, f_spin, lfailure) lfailure = ((fragments%ke_budget - fragments%ke_spin - fragments%ke_orbit) < 0.0_DP) if (lfailure) then - call io_log_one_message(FRAGGLE_LOG_OUT, " ") - call io_log_one_message(FRAGGLE_LOG_OUT, "Spin failure diagnostics") + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, " ") + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "Spin failure diagnostics") write(message, *) fragments%ke_budget - call io_log_one_message(FRAGGLE_LOG_OUT, "ke_budget : " // trim(adjustl(message))) + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "ke_budget : " // trim(adjustl(message))) write(message, *) fragments%ke_spin - call io_log_one_message(FRAGGLE_LOG_OUT, "ke_spin : " // trim(adjustl(message))) + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "ke_spin : " // trim(adjustl(message))) write(message, *) fragments%ke_orbit - call io_log_one_message(FRAGGLE_LOG_OUT, "ke_orbit : " // trim(adjustl(message))) + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "ke_orbit : " // trim(adjustl(message))) write(message, *) fragments%ke_budget - fragments%ke_spin - fragments%ke_orbit - call io_log_one_message(FRAGGLE_LOG_OUT, "ke_remainder : " // trim(adjustl(message))) + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "ke_remainder : " // trim(adjustl(message))) end if end select @@ -378,7 +385,7 @@ subroutine fraggle_generate_tan_vel(collision_system, lfailure) associate(impactors => collision_system%impactors, nfrag => collision_system%fragments%nbody) select type(fragments => collision_system%fragments) - class is (fraggle_fragments) + class is (fraggle_fragments(*)) lfailure = .false. allocate(v_t_initial, mold=fragments%v_t_mag) @@ -427,20 +434,20 @@ subroutine fraggle_generate_tan_vel(collision_system, lfailure) fragments%rc(:,:) = fragments%rc(:,:) * 1.1_DP end do if (lfailure) then - call io_log_one_message(FRAGGLE_LOG_OUT, " ") - call io_log_one_message(FRAGGLE_LOG_OUT, "Tangential velocity failure diagnostics") + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, " ") + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "Tangential velocity failure diagnostics") call fragments%get_angular_momentum() L_frag_tot = fragments%Lspin(:) + fragments%Lorbit(:) write(message, *) .mag.(fragments%L_budget(:) - L_frag_tot(:)) / (.mag.collision_system%Ltot(:,1)) - call io_log_one_message(FRAGGLE_LOG_OUT, "|L_remainder| : " // trim(adjustl(message))) + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "|L_remainder| : " // trim(adjustl(message))) write(message, *) fragments%ke_budget - call io_log_one_message(FRAGGLE_LOG_OUT, "ke_budget : " // trim(adjustl(message))) + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "ke_budget : " // trim(adjustl(message))) write(message, *) fragments%ke_spin - call io_log_one_message(FRAGGLE_LOG_OUT, "ke_spin : " // trim(adjustl(message))) + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "ke_spin : " // trim(adjustl(message))) write(message, *) fragments%ke_orbit - call io_log_one_message(FRAGGLE_LOG_OUT, "ke_tangential : " // trim(adjustl(message))) + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "ke_tangential : " // trim(adjustl(message))) write(message, *) fragments%ke_budget - fragments%ke_spin - fragments%ke_orbit - call io_log_one_message(FRAGGLE_LOG_OUT, "ke_radial : " // trim(adjustl(message))) + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "ke_radial : " // trim(adjustl(message))) end if end select end associate @@ -466,7 +473,7 @@ function solve_fragment_tan_vel(lfailure, v_t_mag_input) result(v_t_mag_output) real(DP), dimension(NDIM) :: L_lin_others, L_orb_others, L, vtmp select type(fragments => collision_system%fragments) - class is (fraggle_fragments) + class is (fraggle_fragments(*)) associate(nfrag => fragments%nbody) lfailure = .false. ! We have 6 constraint equations (2 vector constraints in 3 dimensions each) @@ -513,7 +520,7 @@ function tangential_objective_function(v_t_mag_input, lfailure) result(fval) real(DP) :: keo select type(fragments => collision_system%fragments) - class is (fraggle_fragments) + class is (fraggle_fragments(*)) associate(impactors => collision_system%impactors, nfrag => fragments%nbody) lfailure = .false. @@ -559,7 +566,7 @@ subroutine fraggle_generate_rad_vel(collision_system, lfailure) associate(impactors => collision_system%impactors, nfrag => collision_system%fragments%nbody) select type(fragments => collision_system%fragments) - class is (fraggle_fragments) + class is (fraggle_fragments(*)) ! Set the "target" ke for the radial component allocate(v_r_initial, source=fragments%v_r_mag) @@ -601,16 +608,16 @@ subroutine fraggle_generate_rad_vel(collision_system, lfailure) lfailure = abs((fragments%ke_budget - (fragments%ke_orbit + fragments%ke_spin)) / fragments%ke_budget) > FRAGGLE_ETOL if (lfailure) then - call io_log_one_message(FRAGGLE_LOG_OUT, " ") - call io_log_one_message(FRAGGLE_LOG_OUT, "Radial velocity failure diagnostics") + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, " ") + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "Radial velocity failure diagnostics") write(message, *) fragments%ke_budget - call io_log_one_message(FRAGGLE_LOG_OUT, "ke_budget : " // trim(adjustl(message))) + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "ke_budget : " // trim(adjustl(message))) write(message, *) fragments%ke_spin - call io_log_one_message(FRAGGLE_LOG_OUT, "ke_spin : " // trim(adjustl(message))) + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "ke_spin : " // trim(adjustl(message))) write(message, *) fragments%ke_orbit - call io_log_one_message(FRAGGLE_LOG_OUT, "ke_orbit : " // trim(adjustl(message))) + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "ke_orbit : " // trim(adjustl(message))) write(message, *) fragments%ke_budget - (fragments%ke_orbit + fragments%ke_spin) - call io_log_one_message(FRAGGLE_LOG_OUT, "ke_remainder : " // trim(adjustl(message))) + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "ke_remainder : " // trim(adjustl(message))) end if end select @@ -636,16 +643,14 @@ function radial_objective_function(v_r_mag_input) result(fval) associate(impactors => collision_system%impactors, nfrag => collision_system%fragments%nbody) select type(fragments => collision_system%fragments) - class is (fraggle_fragments) + class is (fraggle_fragments(*)) allocate(v_shift, mold=fragments%vb) v_shift(:,:) = fraggle_util_vmag_to_vb(v_r_mag_input, fragments%v_r_unit, fragments%v_t_mag, fragments%v_t_unit, fragments%mass, impactors%vbcom) - !$omp do simd firstprivate(fragments) do i = 1,fragments%nbody rotmag2 = fragments%rot(1,i)**2 + fragments%rot(2,i)**2 + fragments%rot(3,i)**2 vmag2 = v_shift(1,i)**2 + v_shift(2,i)**2 + v_shift(3,i)**2 kearr(i) = fragments%mass(i) * (fragments%Ip(3, i) * fragments%radius(i)**2 * rotmag2 + vmag2) end do - !$omp end do simd keo = 2 * fragments%ke_budget - sum(kearr(:)) ke_radial = fragments%ke_budget - fragments%ke_orbit - fragments%ke_spin ! The following ensures that fval = 0 is a local minimum, which is what the BFGS method is searching for diff --git a/src/fraggle/fraggle_io.f90 b/src/fraggle/fraggle_io.f90 index e13c46472..7c943b5d6 100644 --- a/src/fraggle/fraggle_io.f90 +++ b/src/fraggle/fraggle_io.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(fraggle_classes) s_fraggle_io +submodule(fraggle) s_fraggle_io use swiftest contains @@ -29,7 +29,7 @@ module subroutine fraggle_io_log_regime(collision_system) write(LUN, *) " Fraggle collisional regime determination results" write(LUN, *) "--------------------------------------------------------------------" write(LUN, *) "True number of impactors : ",impactors%ncoll - write(LUN, *) "Index list of true impactors : ",impactors%idx(1:impactors%ncoll) + write(LUN, *) "Index list of true impactors : ",impactors%id(1:impactors%ncoll) select case(impactors%regime) case(COLLRESOLVE_REGIME_MERGE) write(LUN, *) "Regime: Merge" diff --git a/src/fraggle/fraggle_resolve.f90 b/src/fraggle/fraggle_resolve.f90 new file mode 100644 index 000000000..e2cb6677b --- /dev/null +++ b/src/fraggle/fraggle_resolve.f90 @@ -0,0 +1,192 @@ +!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh +!! This file is part of Swiftest. +!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License +!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. +!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty +!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. +!! You should have received a copy of the GNU General Public License along with Swiftest. +!! If not, see: https://www.gnu.org/licenses. + +submodule(fraggle) s_fraggle_resolve + use swiftest + use symba +contains + + module function fraggle_resolve_disruption(system, param, t) result(status) + !! author: Jennifer L.L. Pouplin, Carlisle A. Wishard, and David A. Minton + !! + !! Create the fragments resulting from a non-catastrophic disruption collision + !! + implicit none + ! Arguments + class(base_nbody_system), intent(inout) :: system !! SyMBA nbody system object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions + real(DP), intent(in) :: t !! Time of collision + ! Result + integer(I4B) :: status !! Status flag assigned to this outcome + ! Internals + integer(I4B) :: i, ibiggest, nfrag + logical :: lfailure + character(len=STRMAX) :: message + real(DP) :: dpe + + select type(system) + class is (swiftest_nbody_system) + select type(param) + class is (swiftest_parameters) + select type(before => system%collision_system%before) + class is (swiftest_nbody_system) + select type(after => system%collision_system%after) + class is (swiftest_nbody_system) + associate(collision_system => system%collision_system, impactors => system%collision_system%impactors, fragments => system%collision_system%fragments) + select case(impactors%regime) + case(COLLRESOLVE_REGIME_DISRUPTION) + message = "Disruption between" + case(COLLRESOLVE_REGIME_SUPERCATASTROPHIC) + message = "Supercatastrophic disruption between" + end select + call collision_resolve_collider_message(system%pl, impactors%id, message) + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, message) + + ! Collisional fragments will be uniformly distributed around the pre-impact barycenter + call collision_system%set_mass_dist(param) + + ! Generate the position and velocity distributions of the fragments + call collision_system%generate_fragments(system, param, lfailure) + + dpe = collision_system%pe(2) - collision_system%pe(1) + system%Ecollisions = system%Ecollisions - dpe + system%Euntracked = system%Euntracked + dpe + + if (lfailure) then + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "No fragment solution found, so treat as a pure hit-and-run") + status = ACTIVE + nfrag = 0 + select type(pl => system%pl) + class is (swiftest_pl) + pl%status(impactors%id(:)) = status + pl%ldiscard(impactors%id(:)) = .false. + pl%lcollision(impactors%id(:)) = .false. + end select + allocate(after%pl, source=before%pl) ! Be sure to save the pl so that snapshots still work + else + ! Populate the list of new bodies + nfrag = fragments%nbody + write(message, *) nfrag + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "Generating " // trim(adjustl(message)) // " fragments") + select case(impactors%regime) + case(COLLRESOLVE_REGIME_DISRUPTION) + status = DISRUPTED + ibiggest = impactors%id(maxloc(system%pl%Gmass(impactors%id(:)), dim=1)) + fragments%id(1) = system%pl%id(ibiggest) + fragments%id(2:nfrag) = [(i, i = param%maxid + 1, param%maxid + nfrag - 1)] + param%maxid = fragments%id(nfrag) + case(COLLRESOLVE_REGIME_SUPERCATASTROPHIC) + status = SUPERCATASTROPHIC + fragments%id(1:nfrag) = [(i, i = param%maxid + 1, param%maxid + nfrag)] + param%maxid = fragments%id(nfrag) + end select + + call collision_resolve_mergeaddsub(system, param, t, status) + end if + end associate + end select + end select + end select + end select + + return + end function fraggle_resolve_disruption + + + module function fraggle_resolve_hitandrun(system, param, t) result(status) + !! author: Jennifer L.L. Pouplin, Carlisle A. Wishard, and David A. Minton + !! + !! Create the fragments resulting from a non-catastrophic hit-and-run collision + !! + implicit none + ! Arguments + class(base_nbody_system), intent(inout) :: system !! SyMBA nbody system object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions + real(DP), intent(in) :: t !! Time of collision + ! Result + integer(I4B) :: status !! Status flag assigned to this outcom + ! Internals + integer(I4B) :: i, ibiggest, nfrag, jtarg, jproj + logical :: lpure + character(len=STRMAX) :: message + real(DP) :: dpe + + select type(system) + class is (swiftest_nbody_system) + select type(param) + class is (swiftest_parameters) + select type(before => system%collision_system%before) + class is (swiftest_nbody_system) + select type(after => system%collision_system%after) + class is (swiftest_nbody_system) + associate(collision_system => system%collision_system, impactors => system%collision_system%impactors, fragments => system%collision_system%fragments) + message = "Hit and run between" + call collision_resolve_collider_message(system%pl, impactors%id, message) + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, trim(adjustl(message))) + + if (impactors%mass(1) > impactors%mass(2)) then + jtarg = 1 + jproj = 2 + else + jtarg = 2 + jproj = 1 + end if + + if (impactors%mass_dist(2) > 0.9_DP * impactors%mass(jproj)) then ! Pure hit and run, so we'll just keep the two bodies untouched + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "Pure hit and run. No new fragments generated.") + nfrag = 0 + lpure = .true. + else ! Imperfect hit and run, so we'll keep the largest body and destroy the other + lpure = .false. + call collision_system%set_mass_dist(param) + + ! Generate the position and velocity distributions of the fragments + call collision_system%generate_fragments(system, param, lpure) + + dpe = collision_system%pe(2) - collision_system%pe(1) + system%Ecollisions = system%Ecollisions - dpe + system%Euntracked = system%Euntracked + dpe + + if (lpure) then + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "Should have been a pure hit and run instead") + nfrag = 0 + else + nfrag = fragments%nbody + write(message, *) nfrag + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "Generating " // trim(adjustl(message)) // " fragments") + end if + end if + if (lpure) then ! Reset these bodies back to being active so that nothing further is done to them + status = HIT_AND_RUN_PURE + select type(pl => system%pl) + class is (symba_pl) + pl%status(impactors%id(:)) = ACTIVE + pl%ldiscard(impactors%id(:)) = .false. + pl%lcollision(impactors%id(:)) = .false. + end select + allocate(after%pl, source=before%pl) ! Be sure to save the pl so that snapshots still work + else + ibiggest = impactors%id(maxloc(system%pl%Gmass(impactors%id(:)), dim=1)) + fragments%id(1) = system%pl%id(ibiggest) + fragments%id(2:nfrag) = [(i, i = param%maxid + 1, param%maxid + nfrag - 1)] + param%maxid = fragments%id(nfrag) + status = HIT_AND_RUN_DISRUPT + call collision_resolve_mergeaddsub(system, param, t, status) + end if + end associate + end select + end select + end select + end select + + + return + end function fraggle_resolve_hitandrun + +end submodule s_fraggle_resolve \ No newline at end of file diff --git a/src/fraggle/fraggle_set.f90 b/src/fraggle/fraggle_set.f90 index b0cfdf951..42c7e4500 100644 --- a/src/fraggle/fraggle_set.f90 +++ b/src/fraggle/fraggle_set.f90 @@ -7,8 +7,9 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(fraggle_classes) s_fraggle_set +submodule(fraggle) s_fraggle_set use swiftest + use symba contains module subroutine fraggle_set_budgets(self) @@ -23,17 +24,18 @@ module subroutine fraggle_set_budgets(self) real(DP), dimension(NDIM) :: dL associate(impactors => self%impactors) - select type(fragments => self%fragments) - class is (fraggle_fragments) + select type(fragments => self%fragments) + class is (fraggle_fragments(*)) - dEtot = self%Etot(2) - self%Etot(1) - dL(:) = self%Ltot(:,2) - self%Ltot(:,1) + dEtot = self%Etot(2) - self%Etot(1) + dL(:) = self%Ltot(:,2) - self%Ltot(:,1) - fragments%L_budget(:) = -dL(:) - fragments%ke_budget = -(dEtot - 0.5_DP * fragments%mtot * dot_product(impactors%vbcom(:), impactors%vbcom(:))) - impactors%Qloss + fragments%L_budget(:) = -dL(:) + fragments%ke_budget = -(dEtot - 0.5_DP * fragments%mtot * dot_product(impactors%vbcom(:), impactors%vbcom(:))) - impactors%Qloss - end select + end select end associate + return end subroutine fraggle_set_budgets @@ -47,7 +49,7 @@ module subroutine fraggle_set_mass_dist(self, param) implicit none ! Arguments class(fraggle_system), intent(inout) :: self !! Fraggle collision system object - class(swiftest_parameters), intent(in) :: param !! Current Swiftest run configuration parameters + class(base_parameters), intent(in) :: param !! Current Swiftest run configuration parameters ! Internals integer(I4B) :: i, jproj, jtarg, nfrag, istart real(DP), dimension(2) :: volume @@ -62,8 +64,6 @@ module subroutine fraggle_set_mass_dist(self, param) integer(I4B), parameter :: iMrem = 3 associate(impactors => self%impactors) - select type(fragments => self%fragments) - class is (fraggle_fragments) ! Get mass weighted mean of Ip and density volume(1:2) = 4._DP / 3._DP * PI * impactors%radius(1:2)**3 mtot = sum(impactors%mass(:)) @@ -85,7 +85,7 @@ module subroutine fraggle_set_mass_dist(self, param) ! Check to see if our size distribution would give us a smaller number of fragments than the maximum number select type(param) - class is (symba_parameters) + class is (base_parameters) min_mfrag = (param%min_GMfrag / param%GU) ! The number of fragments we generate is bracked by the minimum required by fraggle_generate (7) and the ! maximum set by the NFRAG_SIZE_MULTIPLIER which limits the total number of fragments to prevent the nbody @@ -106,61 +106,70 @@ module subroutine fraggle_set_mass_dist(self, param) i = i + 1 end do if (i < nfrag) nfrag = max(i, NFRAGMIN) ! The sfd would actually give us fewer fragments than our maximum - - call fragments%setup(nfrag, param) + call self%setup_fragments(nfrag) + case (COLLRESOLVE_REGIME_MERGE, COLLRESOLVE_REGIME_GRAZE_AND_MERGE) - call fragments%setup(1, param) - fragments%mass(1) = impactors%mass_dist(1) - fragments%radius(1) = impactors%radius(jtarg) - fragments%density(1) = impactors%mass_dist(1) / volume(jtarg) - if (param%lrotation) fragments%Ip(:, 1) = impactors%Ip(:,1) + + call self%setup_fragments(1) + select type(fragments => self%fragments) + class is (fraggle_fragments(*)) + fragments%mass(1) = impactors%mass_dist(1) + fragments%radius(1) = impactors%radius(jtarg) + fragments%density(1) = impactors%mass_dist(1) / volume(jtarg) + if (param%lrotation) fragments%Ip(:, 1) = impactors%Ip(:,1) + end select return case default write(*,*) "fraggle_set_mass_dist_fragments error: Unrecognized regime code",impactors%regime end select - fragments%mtot = mtot - - ! Make the first two bins the same as the Mlr and Mslr values that came from collision_regime - fragments%mass(1) = impactors%mass_dist(iMlr) - fragments%mass(2) = impactors%mass_dist(iMslr) - - ! Distribute the remaining mass the 3:nfrag bodies following the model SFD given by slope BETA - mremaining = impactors%mass_dist(iMrem) - do i = iMrem, nfrag - mfrag = (1 + i - iMslr)**(-3._DP / BETA) * impactors%mass_dist(iMslr) - fragments%mass(i) = mfrag - mremaining = mremaining - mfrag - end do - ! If there is any residual mass (either positive or negative) we will distribute remaining mass proportionally among the the fragments - if (mremaining < 0.0_DP) then ! If the remainder is negative, this means that that the number of fragments required by the SFD is smaller than our lower limit set by fraggle_generate. - istart = iMrem ! We will reduce the mass of the 3:nfrag bodies to prevent the second-largest fragment from going smaller - else ! If the remainder is postiive, this means that the number of fragments required by the SFD is larger than our upper limit set by computational expediency. - istart = iMslr ! We will increase the mass of the 2:nfrag bodies to compensate, which ensures that the second largest fragment remains the second largest - end if - mfrag = 1._DP + mremaining / sum(fragments%mass(istart:nfrag)) - fragments%mass(istart:nfrag) = fragments%mass(istart:nfrag) * mfrag + select type(fragments => self%fragments) + class is (fraggle_fragments(*)) + fragments%mtot = mtot - ! There may still be some small residual due to round-off error. If so, simply add it to the last bin of the mass distribution. - mremaining = fragments%mtot - sum(fragments%mass(1:nfrag)) - fragments%mass(nfrag) = fragments%mass(nfrag) + mremaining + ! Make the first two bins the same as the Mlr and Mslr values that came from collision_regime + fragments%mass(1) = impactors%mass_dist(iMlr) + fragments%mass(2) = impactors%mass_dist(iMslr) + + ! Distribute the remaining mass the 3:nfrag bodies following the model SFD given by slope BETA + mremaining = impactors%mass_dist(iMrem) + do i = iMrem, nfrag + mfrag = (1 + i - iMslr)**(-3._DP / BETA) * impactors%mass_dist(iMslr) + fragments%mass(i) = mfrag + mremaining = mremaining - mfrag + end do + + ! If there is any residual mass (either positive or negative) we will distribute remaining mass proportionally among the the fragments + if (mremaining < 0.0_DP) then ! If the remainder is negative, this means that that the number of fragments required by the SFD is smaller than our lower limit set by fraggle_generate. + istart = iMrem ! We will reduce the mass of the 3:nfrag bodies to prevent the second-largest fragment from going smaller + else ! If the remainder is postiive, this means that the number of fragments required by the SFD is larger than our upper limit set by computational expediency. + istart = iMslr ! We will increase the mass of the 2:nfrag bodies to compensate, which ensures that the second largest fragment remains the second largest + end if + mfrag = 1._DP + mremaining / sum(fragments%mass(istart:nfrag)) + fragments%mass(istart:nfrag) = fragments%mass(istart:nfrag) * mfrag + + ! There may still be some small residual due to round-off error. If so, simply add it to the last bin of the mass distribution. + mremaining = fragments%mtot - sum(fragments%mass(1:nfrag)) + fragments%mass(nfrag) = fragments%mass(nfrag) + mremaining + + ! Compute physical properties of the new fragments + select case(impactors%regime) + case(COLLRESOLVE_REGIME_HIT_AND_RUN) ! The hit and run case always preserves the largest body intact, so there is no need to recompute the physical properties of the first fragment + fragments%radius(1) = impactors%radius(jtarg) + fragments%density(1) = impactors%mass_dist(iMlr) / volume(jtarg) + fragments%Ip(:, 1) = impactors%Ip(:,1) + istart = 2 + case default + istart = 1 + end select + + fragments%density(istart:nfrag) = fragments%mtot / sum(volume(:)) + fragments%radius(istart:nfrag) = (3 * fragments%mass(istart:nfrag) / (4 * PI * fragments%density(istart:nfrag)))**(1.0_DP / 3.0_DP) + do i = istart, nfrag + fragments%Ip(:, i) = Ip_avg(:) + end do - ! Compute physical properties of the new fragments - select case(impactors%regime) - case(COLLRESOLVE_REGIME_HIT_AND_RUN) ! The hit and run case always preserves the largest body intact, so there is no need to recompute the physical properties of the first fragment - fragments%radius(1) = impactors%radius(jtarg) - fragments%density(1) = impactors%mass_dist(iMlr) / volume(jtarg) - fragments%Ip(:, 1) = impactors%Ip(:,1) - istart = 2 - case default - istart = 1 end select - fragments%density(istart:nfrag) = fragments%mtot / sum(volume(:)) - fragments%radius(istart:nfrag) = (3 * fragments%mass(istart:nfrag) / (4 * PI * fragments%density(istart:nfrag)))**(1.0_DP / 3.0_DP) - do i = istart, nfrag - fragments%Ip(:, i) = Ip_avg(:) - end do - end select end associate return diff --git a/src/fraggle/fraggle_setup.f90 b/src/fraggle/fraggle_setup.f90 index 2e67f6c7d..b612f05b2 100644 --- a/src/fraggle/fraggle_setup.f90 +++ b/src/fraggle/fraggle_setup.f90 @@ -7,64 +7,24 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule (fraggle_classes) s_fraggle_setup +submodule (fraggle) s_fraggle_setup use swiftest + use symba contains - module subroutine fraggle_setup_reset_fragments(self) + module subroutine fraggle_setup_fragments_system(self, nfrag) !! author: David A. Minton !! - !! Resets all position and velocity-dependent fragment quantities in order to do a fresh calculation (does not reset mass, radius, or other values that get set prior to the call to fraggle_generate) + !! Initializer for the fragments of the collision system. implicit none ! Arguments - class(fraggle_fragments), intent(inout) :: self + class(fraggle_system), intent(inout) :: self !! Encounter collision system object + integer(I4B), intent(in) :: nfrag !! Number of fragments to create - self%rb(:,:) = 0.0_DP - self%vb(:,:) = 0.0_DP - self%rot(:,:) = 0.0_DP - self%v_r_unit(:,:) = 0.0_DP - self%v_t_unit(:,:) = 0.0_DP - self%v_n_unit(:,:) = 0.0_DP - - self%rmag(:) = 0.0_DP - self%rotmag(:) = 0.0_DP - self%v_r_mag(:) = 0.0_DP - self%v_t_mag(:) = 0.0_DP + if (allocated(self%fragments)) deallocate(self%fragments) + allocate(fraggle_fragments(nfrag) :: self%fragments) return - end subroutine fraggle_setup_reset_fragments - - - module subroutine fraggle_setup_fragments(self, n, param) - !! author: David A. Minton - !! - !! Allocates arrays for n fragments in a Fraggle system. Passing n = 0 deallocates all arrays. - implicit none - ! Arguments - class(fraggle_fragments), intent(inout) :: self - integer(I4B), intent(in) :: n - class(swiftest_parameters), intent(in) :: param - - call collision_setup_fragments(self, n, param) - if (n < 0) return - - if (allocated(self%rotmag)) deallocate(self%rotmag) - if (allocated(self%v_r_mag)) deallocate(self%v_r_mag) - if (allocated(self%v_t_mag)) deallocate(self%v_t_mag) - if (allocated(self%v_n_mag)) deallocate(self%v_t_mag) - - if (n == 0) return - - allocate(self%rotmag(n)) - allocate(self%v_r_mag(n)) - allocate(self%v_t_mag(n)) - allocate(self%v_n_mag(n)) - - call self%reset() - - return - end subroutine fraggle_setup_fragments - - + end subroutine fraggle_setup_fragments_system end submodule s_fraggle_setup \ No newline at end of file diff --git a/src/fraggle/fraggle_util.f90 b/src/fraggle/fraggle_util.f90 index a46ec64a0..62581c0db 100644 --- a/src/fraggle/fraggle_util.f90 +++ b/src/fraggle/fraggle_util.f90 @@ -7,19 +7,18 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(fraggle_classes) s_fraggle_util +submodule(fraggle) s_fraggle_util use swiftest + use symba contains - - module subroutine fraggle_util_get_angular_momentum(self) !! Author: David A. Minton !! !! Calcualtes the current angular momentum of the fragments implicit none ! Arguments - class(fraggle_fragments), intent(inout) :: self !! Fraggle fragment system object + class(fraggle_fragments(*)), intent(inout) :: self !! Fraggle fragment system object ! Internals integer(I4B) :: i @@ -43,82 +42,104 @@ module subroutine fraggle_util_construct_temporary_system(self, nbody_system, pa !! Constructs a temporary internal system consisting of active bodies and additional fragments. This internal temporary system is used to calculate system energy with and without fragments implicit none ! Arguments - class(fraggle_system), intent(inout) :: self !! Fraggle collision system object - class(swiftest_nbody_system), intent(in) :: nbody_system !! Original swiftest nbody system object - class(swiftest_parameters), intent(in) :: param !! Current swiftest run configuration parameters - class(swiftest_nbody_system), allocatable, intent(out) :: tmpsys !! Output temporary swiftest nbody system object - class(swiftest_parameters), allocatable, intent(out) :: tmpparam !! Output temporary configuration run parameters + class(fraggle_system), intent(inout) :: self !! Fraggle collision system object + class(base_nbody_system), intent(in) :: nbody_system !! Original swiftest nbody system object + class(base_parameters), intent(in) :: param !! Current swiftest run configuration parameters + class(base_nbody_system), allocatable, intent(out) :: tmpsys !! Output temporary swiftest nbody system object + class(base_parameters), allocatable, intent(out) :: tmpparam !! Output temporary configuration run parameters call self%collision_system%construct_temporary_system(nbody_system, param, tmpsys, tmpparam) - call tmpsys%rescale(tmpparam, self%mscale, self%dscale, self%tscale) + + select type(tmpsys) + class is (swiftest_nbody_system) + select type(tmpparam) + class is (swiftest_parameters) + call tmpsys%rescale(tmpparam, self%mscale, self%dscale, self%tscale) + end select + end select return end subroutine fraggle_util_construct_temporary_system - module subroutine fraggle_util_dealloc_fragments(self) + module subroutine fraggle_util_final_fragments(self) !! author: David A. Minton !! - !! Deallocates all allocatables + !! Finalizer will deallocate all allocatables implicit none ! Arguments - class(fraggle_fragments), intent(inout) :: self - - call collision_util_dealloc_fragments(self) + type(fraggle_fragments(*)), intent(inout) :: self !! Fraggle encountar storage object - if (allocated(self%v_r_mag)) deallocate(self%v_r_mag) - if (allocated(self%v_t_mag)) deallocate(self%v_t_mag) - if (allocated(self%v_n_mag)) deallocate(self%v_n_mag) + call self%collision_fragments%reset() return - end subroutine fraggle_util_dealloc_fragments - + end subroutine fraggle_util_final_fragments - module subroutine fraggle_util_final_impactors(self) + module subroutine fraggle_util_final_system(self) !! author: David A. Minton !! !! Finalizer will deallocate all allocatables implicit none ! Arguments - type(collision_impactors), intent(inout) :: self !! Fraggle encountar storage object + type(fraggle_system), intent(inout) :: self !! Collision impactors storage object - if (allocated(self%idx)) deallocate(self%idx) + call self%reset() + if (allocated(self%impactors)) deallocate(self%impactors) + if (allocated(self%fragments)) deallocate(self%fragments) return - end subroutine fraggle_util_final_impactors + end subroutine fraggle_util_final_system - module subroutine fraggle_util_final_fragments(self) + module subroutine fraggle_util_reset_fragments(self) !! author: David A. Minton !! - !! Finalizer will deallocate all allocatables + !! Resets all position and velocity-dependent fragment quantities in order to do a fresh calculation (does not reset mass, radius, or other values that get set prior to the call to fraggle_generate) implicit none ! Arguments - type(fraggle_fragments), intent(inout) :: self !! Fraggle encountar storage object - - call self%dealloc() + class(fraggle_fragments(*)), intent(inout) :: self + + self%rc(:,:) = 0.0_DP + self%vc(:,:) = 0.0_DP + self%rh(:,:) = 0.0_DP + self%vh(:,:) = 0.0_DP + self%rb(:,:) = 0.0_DP + self%vb(:,:) = 0.0_DP + self%rot(:,:) = 0.0_DP + self%v_r_unit(:,:) = 0.0_DP + self%v_t_unit(:,:) = 0.0_DP + self%v_n_unit(:,:) = 0.0_DP + + self%rmag(:) = 0.0_DP + self%rotmag(:) = 0.0_DP + self%v_r_mag(:) = 0.0_DP + self%v_t_mag(:) = 0.0_DP + self%v_n_mag(:) = 0.0_DP return - end subroutine fraggle_util_final_fragments + end subroutine fraggle_util_reset_fragments - module subroutine fraggle_util_final_system(self) + module subroutine fraggle_util_reset_system(self) !! author: David A. Minton !! - !! Finalizer will deallocate all allocatables + !! Resets the collider system and deallocates all allocatables implicit none ! Arguments - type(fraggle_system), intent(inout) :: self !! Collision impactors storage object - ! Internals - type(swiftest_parameters) :: tmp_param + class(fraggle_system), intent(inout) :: self !! Collision system object - call self%reset(tmp_param) - if (allocated(self%impactors)) deallocate(self%impactors) - if (allocated(self%fragments)) deallocate(self%fragments) + self%dscale = 1.0_DP + self%mscale = 1.0_DP + self%tscale = 1.0_DP + self%vscale = 1.0_DP + self%Escale = 1.0_DP + self%Lscale = 1.0_DP + + call self%collision_system%reset() return - end subroutine fraggle_util_final_system + end subroutine fraggle_util_reset_system module subroutine fraggle_util_restructure(self, impactors, try, f_spin, r_max_start) @@ -127,7 +148,7 @@ module subroutine fraggle_util_restructure(self, impactors, try, f_spin, r_max_s !! Restructure the inputs after a failed attempt failed to find a set of positions and velocities that satisfy the energy and momentum constraints implicit none ! Arguments - class(fraggle_fragments), intent(inout) :: self !! Fraggle fragment system object + class(fraggle_fragments(*)), intent(inout) :: self !! Fraggle fragment system object class(collision_impactors), intent(in) :: impactors !! Fraggle collider system object integer(I4B), intent(in) :: try !! The current number of times Fraggle has tried to find a solution real(DP), intent(inout) :: f_spin !! Fraction of energy/momentum that goes into spin. This decreases ater a failed attempt diff --git a/src/helio/helio_drift.f90 b/src/helio/helio_drift.f90 index 06e98e0fa..d61eb6450 100644 --- a/src/helio/helio_drift.f90 +++ b/src/helio/helio_drift.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule (helio_classes) s_helio_drift +submodule (helio) s_helio_drift use swiftest contains @@ -36,7 +36,7 @@ module subroutine helio_drift_body(self, system, param, dt) iflag(:) = 0 allocate(mu(n)) mu(:) = system%cb%Gmass - call drift_all(mu, self%rh, self%vb, self%nbody, param, dt, self%lmask, iflag) + call swiftest_drift_all(mu, self%rh, self%vb, self%nbody, param, dt, self%lmask, iflag) if (any(iflag(1:n) /= 0)) then where(iflag(1:n) /= 0) self%status(1:n) = DISCARDED_DRIFTERR do i = 1, n diff --git a/src/helio/helio_gr.f90 b/src/helio/helio_gr.f90 index 13209ce1a..7a5ac9525 100644 --- a/src/helio/helio_gr.f90 +++ b/src/helio/helio_gr.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(helio_classes) s_helio_gr +submodule(helio) s_helio_gr use swiftest contains @@ -26,7 +26,7 @@ pure module subroutine helio_gr_kick_getacch_pl(self, param) if (self%nbody == 0) return associate(pl => self, npl => self%nbody) - call gr_kick_getacch(pl%mu, pl%rh, pl%lmask, npl, param%inv_c2, pl%agr) + call swiftest_gr_kick_getacch(pl%mu, pl%rh, pl%lmask, npl, param%inv_c2, pl%agr) pl%ah(:,1:npl) = pl%ah(:,1:npl) + pl%agr(:,1:npl) end associate @@ -49,7 +49,7 @@ pure module subroutine helio_gr_kick_getacch_tp(self, param) if (self%nbody == 0) return associate(tp => self, ntp => self%nbody) - call gr_kick_getacch(tp%mu, tp%rh, tp%lmask, ntp, param%inv_c2, tp%agr) + call swiftest_gr_kick_getacch(tp%mu, tp%rh, tp%lmask, ntp, param%inv_c2, tp%agr) tp%ah(:,1:ntp) = tp%ah(:,1:ntp) + tp%agr(:,1:ntp) end associate @@ -77,7 +77,7 @@ pure module subroutine helio_gr_p4_pl(self, system, param, dt) associate(pl => self, npl => self%nbody) do concurrent(i = 1:npl, pl%lmask(i)) - call gr_p4_pos_kick(param, pl%rh(:, i), pl%vb(:, i), dt) + call swiftest_gr_p4_pos_kick(param, pl%rh(:, i), pl%vb(:, i), dt) end do end associate @@ -105,7 +105,7 @@ pure module subroutine helio_gr_p4_tp(self, system, param, dt) associate(tp => self, ntp => self%nbody) do concurrent(i = 1:ntp, tp%lmask(i)) - call gr_p4_pos_kick(param, tp%rh(:, i), tp%vb(:, i), dt) + call swiftest_gr_p4_pos_kick(param, tp%rh(:, i), tp%vb(:, i), dt) end do end associate diff --git a/src/helio/helio_kick.f90 b/src/helio/helio_kick.f90 index 03bc688b5..525990d12 100644 --- a/src/helio/helio_kick.f90 +++ b/src/helio/helio_kick.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(helio_classes) s_helio_kick +submodule(helio) s_helio_kick use swiftest contains @@ -77,7 +77,7 @@ module subroutine helio_kick_getacch_tp(self, system, param, t, lbeg) if (system%lbeg) then call tp%accel_int(param, pl%Gmass(1:npl), pl%rbeg(:,1:npl), npl) else - call tp%accel_int(param, pl%Gmass(1:npl), pl%xend(:,1:npl), npl) + call tp%accel_int(param, pl%Gmass(1:npl), pl%rend(:,1:npl), npl) end if if (param%loblatecb) call tp%accel_obl(system) if (param%lextra_force) call tp%accel_user(system, param, t, lbeg) @@ -114,7 +114,7 @@ module subroutine helio_kick_vb_pl(self, system, param, t, dt, lbeg) if (lbeg) then call pl%set_beg_end(rbeg = pl%rh) else - call pl%set_beg_end(xend = pl%rh) + call pl%set_beg_end(rend = pl%rh) end if do concurrent(i = 1:npl, pl%lmask(i)) pl%vb(1, i) = pl%vb(1, i) + pl%ah(1, i) * dt diff --git a/src/helio/helio_setup.f90 b/src/helio/helio_setup.f90 index 22187f526..80effc1a9 100644 --- a/src/helio/helio_setup.f90 +++ b/src/helio/helio_setup.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(helio_classes) s_helio_setup +submodule(helio) s_helio_setup use swiftest contains diff --git a/src/helio/helio_step.f90 b/src/helio/helio_step.f90 index 318a1bba2..ddcfe0bd5 100644 --- a/src/helio/helio_step.f90 +++ b/src/helio/helio_step.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(helio_classes) s_helio_step +submodule(helio) s_helio_step use swiftest contains diff --git a/src/helio/helio_util.f90 b/src/helio/helio_util.f90 index 73a88d58c..3568fa557 100644 --- a/src/helio/helio_util.f90 +++ b/src/helio/helio_util.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(helio_classes) s_helio_util +submodule(helio) s_helio_util use swiftest contains diff --git a/src/main/swiftest_driver.f90 b/src/main/swiftest_driver.f90 index ebd207e54..b7a0b330b 100644 --- a/src/main/swiftest_driver.f90 +++ b/src/main/swiftest_driver.f90 @@ -20,7 +20,7 @@ program swiftest_driver class(swiftest_nbody_system), allocatable :: system !! Polymorphic object containing the nbody system to be integrated class(swiftest_parameters), allocatable :: param !! Run configuration parameters - character(len=:), allocatable :: integrator !! Integrator type code (see swiftest_globals for symbolic names) + character(len=:), allocatable :: integrator !! Integrator type code (see globals for symbolic names) character(len=:), allocatable :: param_file_name !! Name of the file containing user-defined parameters character(len=:), allocatable :: display_style !! Style of the output display {"STANDARD", "COMPACT", "PROGRESS"}). Default is "STANDARD" integer(I8B) :: istart !! Starting index for loop counter @@ -29,7 +29,7 @@ program swiftest_driver integer(I4B) :: idump !! Dump cadence counter type(walltimer) :: integration_timer !! Object used for computing elapsed wall time real(DP) :: tfrac !! Fraction of total simulation time completed - type(progress_bar) :: pbar !! Object used to print out a progress bar + type(pbar) :: pbar !! Object used to print out a progress bar character(*), parameter :: statusfmt = '("Time = ", ES12.5, "; fraction done = ", F6.3, ' // & '"; Number of active pl, tp = ", I6, ", ", I6)' character(*), parameter :: symbastatfmt = '("Time = ", ES12.5, "; fraction done = ", F6.3, ' // & @@ -38,16 +38,16 @@ program swiftest_driver character(len=64) :: pbarmessage character(*), parameter :: symbacompactfmt = '(";NPLM",ES22.15,$)' - !type(swiftest_storage(nframes=:)), allocatable :: system_history + !type(base_storage(nframes=:)), allocatable :: system_history call io_get_args(integrator, param_file_name, display_style) !> Read in the user-defined parameters file and the initial conditions of the system select case(integrator) case(symba) - allocate(symba_parameters :: param) + allocate(base_parameters :: param) case default - allocate(swiftest_parameters :: param) + allocate(base_parameters :: param) end select param%integrator = trim(adjustl(integrator)) call param%set_display(display_style) diff --git a/src/modules/base.f90 b/src/modules/base.f90 new file mode 100644 index 000000000..83e26eef6 --- /dev/null +++ b/src/modules/base.f90 @@ -0,0 +1,487 @@ +!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh +!! This file is part of Swiftest. +!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License +!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. +!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty +!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. +!! You should have received a copy of the GNU General Public License along with Swiftest. +!! If not, see: https://www.gnu.org/licenses. + +module base + !! author: The Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott + !! + !! Base type definitions. This allows the collision and encounter modules to be defined before the swiftest module. + !! + use globals + implicit none + public + + + !> User defined parameters that are read in from the parameters input file. + !> Each paramter is initialized to a default values. + type, abstract :: base_parameters + character(len=:), allocatable :: integrator !! Symbolic name of the nbody integrator used + character(len=:), allocatable :: param_file_name !! The name of the parameter file + integer(I4B) :: maxid = -1 !! The current maximum particle id number + integer(I4B) :: maxid_collision = 0 !! The current maximum collision id number + real(DP) :: t0 = 0.0_DP !! Integration reference time + real(DP) :: tstart = -1.0_DP !! Integration start time + real(DP) :: tstop = -1.0_DP !! Integration stop time + real(DP) :: dt = -1.0_DP !! Time step + integer(I8B) :: iloop = 0_I8B !! Main loop counter + integer(I4B) :: ioutput = 1 !! Output counter + character(STRMAX) :: incbfile = CB_INFILE !! Name of input file for the central body + character(STRMAX) :: inplfile = PL_INFILE !! Name of input file for massive bodies + character(STRMAX) :: intpfile = TP_INFILE !! Name of input file for test particles + character(STRMAX) :: in_netcdf = NC_INFILE !! Name of system input file for NetCDF input + character(STRMAX) :: in_type = "ASCII" !! Data representation type of input data files + character(STRMAX) :: in_form = "XV" !! Format of input data files ("EL" or "XV") + integer(I4B) :: istep_out = -1 !! Number of time steps between saved outputs + character(STRMAX) :: outfile = BIN_OUTFILE !! Name of output binary file + character(STRMAX) :: out_type = "NETCDF_DOUBLE" !! Binary format of output file + character(STRMAX) :: out_form = "XVEL" !! Data to write to output file + character(STRMAX) :: out_stat = 'NEW' !! Open status for output binary file + integer(I4B) :: dump_cadence = 10 !! Number of output steps between dumping simulation data to file + real(DP) :: rmin = -1.0_DP !! Minimum heliocentric radius for test particle + real(DP) :: rmax = -1.0_DP !! Maximum heliocentric radius for test particle + real(DP) :: rmaxu = -1.0_DP !! Maximum unbound heliocentric radius for test particle + real(DP) :: qmin = -1.0_DP !! Minimum pericenter distance for test particle + character(STRMAX) :: qmin_coord = 'HELIO' !! Coordinate frame to use for qmin + real(DP) :: qmin_alo = -1.0_DP !! Minimum semimajor axis for qmin + real(DP) :: qmin_ahi = -1.0_DP !! Maximum semimajor axis for qmin + real(QP) :: MU2KG = -1.0_QP !! Converts mass units to grams + real(QP) :: TU2S = -1.0_QP !! Converts time units to seconds + real(QP) :: DU2M = -1.0_QP !! Converts distance unit to centimeters + real(DP) :: GU = -1.0_DP !! Universal gravitational constant in the system units + real(DP) :: inv_c2 = -1.0_DP !! Inverse speed of light squared in the system units + real(DP) :: GMTINY = -1.0_DP !! Smallest G*mass that is fully gravitating + real(DP) :: min_GMfrag = -1.0_DP !! Smallest G*mass that can be produced in a fragmentation event + integer(I4B), dimension(:), allocatable :: seed !! Random seeds for fragmentation modeling + logical :: lfragmentation = .false. !! Do fragmentation modeling instead of simple merger. + character(STRMAX) :: encounter_save = "NONE" !! Indicate if and how encounter data should be saved + logical :: lenc_save_trajectory = .false. !! Indicates that when encounters are saved, the full trajectory through recursion steps are saved + logical :: lenc_save_closest = .false. !! Indicates that when encounters are saved, the closest approach distance between pairs of bodies is saved + character(NAMELEN) :: interaction_loops = "ADAPTIVE" !! Method used to compute interaction loops. Options are "TRIANGULAR", "FLAT", or "ADAPTIVE" + character(NAMELEN) :: encounter_check_plpl = "ADAPTIVE" !! Method used to compute pl-pl encounter checks. Options are "TRIANGULAR", "SORTSWEEP", or "ADAPTIVE" + character(NAMELEN) :: encounter_check_pltp = "ADAPTIVE" !! Method used to compute pl-tp encounter checks. Options are "TRIANGULAR", "SORTSWEEP", or "ADAPTIVE" + + ! The following are used internally, and are not set by the user, but instead are determined by the input value of INTERACTION_LOOPS + logical :: lflatten_interactions = .false. !! Use the flattened upper triangular matrix for pl-pl interaction loops + logical :: ladaptive_interactions = .false. !! Adaptive interaction loop is turned on (choose between TRIANGULAR and FLAT based on periodic timing tests) + logical :: lencounter_sas_plpl = .false. !! Use the Sort and Sweep algorithm to prune the encounter list before checking for close encounters + logical :: lencounter_sas_pltp = .false. !! Use the Sort and Sweep algorithm to prune the encounter list before checking for close encounters + logical :: ladaptive_encounters_plpl = .false. !! Adaptive encounter checking is turned on (choose between TRIANGULAR or SORTSWEEP based on periodic timing tests) + logical :: ladaptive_encounters_pltp = .false. !! Adaptive encounter checking is turned on (choose between TRIANGULAR or SORTSWEEP based on periodic timing tests) + + ! Logical flags to turn on or off various features of the code + logical :: lrhill_present = .false. !! Hill radii are given as an input rather than calculated by the code (can be used to inflate close encounter regions manually) + logical :: lextra_force = .false. !! User defined force function turned on + logical :: lbig_discard = .false. !! Save big bodies on every discard + logical :: lclose = .false. !! Turn on close encounters + logical :: lenergy = .false. !! Track the total energy of the system + logical :: loblatecb = .false. !! Calculate acceleration from oblate central body (automatically turns true if nonzero J2 is input) + logical :: lrotation = .false. !! Include rotation states of big bodies + logical :: ltides = .false. !! Include tidal dissipation + + ! Initial values to pass to the energy report subroutine (usually only used in the case of a restart, otherwise these will be updated with initial conditions values) + real(DP) :: Eorbit_orig = 0.0_DP !! Initial orbital energy + real(DP) :: GMtot_orig = 0.0_DP !! Initial system mass + real(DP), dimension(NDIM) :: Ltot_orig = 0.0_DP !! Initial total angular momentum vector + real(DP), dimension(NDIM) :: Lorbit_orig = 0.0_DP !! Initial orbital angular momentum + real(DP), dimension(NDIM) :: Lspin_orig = 0.0_DP !! Initial spin angular momentum vector + real(DP), dimension(NDIM) :: Lescape = 0.0_DP !! Angular momentum of bodies that escaped the system (used for bookeeping) + real(DP) :: GMescape = 0.0_DP !! Mass of bodies that escaped the system (used for bookeeping) + real(DP) :: Ecollisions = 0.0_DP !! Energy lost from system due to collisions + real(DP) :: Euntracked = 0.0_DP !! Energy gained from system due to escaped bodies + logical :: lfirstenergy = .true. !! This is the first time computing energe + logical :: lfirstkick = .true. !! Initiate the first kick in a symplectic step + logical :: lrestart = .false. !! Indicates whether or not this is a restarted run + + character(len=:), allocatable :: display_style !! Style of the output display {"STANDARD", "COMPACT"}). Default is "STANDARD" + integer(I4B) :: display_unit !! File unit number for display (either to stdout or to a log file) + logical :: log_output = .false. !! Logs the output to file instead of displaying it on the terminal + + ! Future features not implemented or in development + logical :: lgr = .false. !! Turn on GR + logical :: lyarkovsky = .false. !! Turn on Yarkovsky effect + logical :: lyorp = .false. !! Turn on YORP effect + contains + procedure(abstract_io_dump_param), deferred :: dump + procedure(abstract_io_param_reader), deferred :: reader + procedure(abstract_io_param_writer), deferred :: writer + procedure(abstract_io_read_in_param), deferred :: read_in + end type base_parameters + + abstract interface + subroutine abstract_io_dump_param(self, param_file_name) + import base_parameters + implicit none + class(base_parameters),intent(in) :: self !! Output collection of parameters + character(len=*), intent(in) :: param_file_name !! Parameter input file name (i.e. param.in) + end subroutine abstract_io_dump_param + + subroutine abstract_io_param_reader(self, unit, iotype, v_list, iostat, iomsg) + import base_parameters, I4B + implicit none + class(base_parameters), intent(inout) :: self !! Collection of parameters + integer(I4B), intent(in) :: unit !! File unit number + character(len=*), intent(in) :: iotype !! Dummy argument passed to the input/output procedure contains the text from the char-literal-constant, prefixed with DT. + !! If you do not include a char-literal-constant, the iotype argument contains only DT. + character(len=*), intent(in) :: v_list(:) !! The first element passes the integrator code to the reader + integer(I4B), intent(out) :: iostat !! IO status code + character(len=*), intent(inout) :: iomsg !! Message to pass if iostat /= 0 + end subroutine abstract_io_param_reader + + subroutine abstract_io_param_writer(self, unit, iotype, v_list, iostat, iomsg) + import base_parameters, I4B + implicit none + class(base_parameters), intent(in) :: self !! Collection of parameters + integer(I4B), intent(in) :: unit !! File unit number + character(len=*), intent(in) :: iotype !! Dummy argument passed to the input/output procedure contains the text from the char-literal-constant, prefixed with DT. + !! If you do not include a char-literal-constant, the iotype argument contains only DT. + integer(I4B), intent(in) :: v_list(:) !! Not used in this procedure + integer(I4B), intent(out) :: iostat !! IO status code + character(len=*), intent(inout) :: iomsg !! Message to pass if iostat /= 0 + end subroutine abstract_io_param_writer + + subroutine abstract_io_read_in_param(self, param_file_name) + import base_parameters + implicit none + class(base_parameters), intent(inout) :: self !! Current run configuration parameters + character(len=*), intent(in) :: param_file_name !! Parameter input file name (i.e. param.in) + end subroutine abstract_io_read_in_param + end interface + + !! This derived datatype stores the NetCDF ID values for each of the variables included in the NetCDF data file. This is used as the base class defined in base + type, abstract :: base_io_netcdf_parameters + character(STRMAX) :: file_name !! Name of the output file + integer(I4B) :: out_type !! output type (will be assigned either NF90_DOUBLE or NF90_FLOAT, depending on the user parameter) + integer(I4B) :: id !! ID for the output file + integer(I4B) :: discard_body_id_varid !! ID for the id of the other body involved in the discard + integer(I4B) :: id_chunk !! Chunk size for the id dimension variables + integer(I4B) :: time_chunk !! Chunk size for the time dimension variables + logical :: lpseudo_vel_exists = .false. !! Logical flag to indicate whether or not the pseudovelocity vectors were present in an old file. + + ! Dimension ids and variable names + character(NAMELEN) :: str_dimname = "string32" !! name of the character string dimension + integer(I4B) :: str_dimid !! ID for the character string dimension + character(NAMELEN) :: time_dimname = "time" !! name of the time dimension + integer(I4B) :: time_dimid !! ID for the time dimension + integer(I4B) :: time_varid !! ID for the time variable + character(NAMELEN) :: name_dimname = "name" !! name of the particle name dimension + integer(I4B) :: name_dimid !! ID for the particle name dimension + integer(I4B) :: name_varid !! ID for the particle name variable + character(NAMELEN) :: space_dimname = "space" !! name of the space dimension + integer(I4B) :: space_dimid !! ID for the space dimension + integer(I4B) :: space_varid !! ID for the space variable + character(len=1), dimension(3) :: space_coords = ["x","y","z"] !! The space dimension coordinate labels + + ! Non-dimension ids and variable names + character(NAMELEN) :: ptype_varname = "particle_type" !! name of the particle type variable + integer(I4B) :: ptype_varid !! ID for the particle type variable + character(NAMELEN) :: id_varname = "id" !! name of the particle id variable + integer(I4B) :: id_varid !! ID for the id variable + character(NAMELEN) :: npl_varname = "npl" !! name of the number of active massive bodies variable + integer(I4B) :: npl_varid !! ID for the number of active massive bodies variable + character(NAMELEN) :: ntp_varname = "ntp" !! name of the number of active test particles variable + integer(I4B) :: ntp_varid !! ID for the number of active test particles variable + character(NAMELEN) :: nplm_varname = "nplm" !! name of the number of active fully interacting massive bodies variable (SyMBA) + integer(I4B) :: nplm_varid !! ID for the number of active fully interacting massive bodies variable (SyMBA) + character(NAMELEN) :: a_varname = "a" !! name of the semimajor axis variable + integer(I4B) :: a_varid !! ID for the semimajor axis variable + character(NAMELEN) :: e_varname = "e" !! name of the eccentricity variable + integer(I4B) :: e_varid !! ID for the eccentricity variable + character(NAMELEN) :: inc_varname = "inc" !! name of the inclination variable + integer(I4B) :: inc_varid !! ID for the inclination variable + character(NAMELEN) :: capom_varname = "capom" !! name of the long. asc. node variable + integer(I4B) :: capom_varid !! ID for the long. asc. node variable + character(NAMELEN) :: omega_varname = "omega" !! name of the arg. of periapsis variable + integer(I4B) :: omega_varid !! ID for the arg. of periapsis variable + character(NAMELEN) :: capm_varname = "capm" !! name of the mean anomaly variable + integer(I4B) :: capm_varid !! ID for the mean anomaly variable + character(NAMELEN) :: varpi_varname = "varpi" !! name of the long. of periapsis variable + integer(I4B) :: varpi_varid !! ID for the long. of periapsis variable + character(NAMELEN) :: lam_varname = "lam" !! name of the mean longitude variable + integer(I4B) :: lam_varid !! ID for the mean longitude variable + character(NAMELEN) :: f_varname = "f" !! name of the true anomaly variable + integer(I4B) :: f_varid !! ID for the true anomaly variable + character(NAMELEN) :: cape_varname = "cape" !! name of the eccentric anomaly variable + integer(I4B) :: cape_varid !! ID for the eccentric anomaly variable + character(NAMELEN) :: rh_varname = "rh" !! name of the heliocentric position vector variable + integer(I4B) :: rh_varid !! ID for the heliocentric position vector variable + character(NAMELEN) :: vh_varname = "vh" !! name of the heliocentric velocity vector variable + integer(I4B) :: vh_varid !! ID for the heliocentric velocity vector variable + character(NAMELEN) :: gr_pseudo_vh_varname = "gr_pseudo_vh" !! name of the heliocentric pseudovelocity vector variable (used in GR only) + integer(I4B) :: gr_pseudo_vh_varid !! ID for the heliocentric pseudovelocity vector variable (used in GR) + character(NAMELEN) :: gmass_varname = "Gmass" !! name of the mass variable + integer(I4B) :: Gmass_varid !! ID for the mass variable + character(NAMELEN) :: rhill_varname = "rhill" !! name of the hill radius variable + integer(I4B) :: rhill_varid !! ID for the hill radius variable + character(NAMELEN) :: radius_varname = "radius" !! name of the radius variable + integer(I4B) :: radius_varid !! ID for the radius variable + character(NAMELEN) :: Ip_varname = "Ip" !! name of the principal moment of inertial variable + integer(I4B) :: Ip_varid !! ID for the axis principal moment of inertia variable + character(NAMELEN) :: rot_varname = "rot" !! name of the rotation vector variable + integer(I4B) :: rot_varid !! ID for the rotation vector variable + character(NAMELEN) :: j2rp2_varname = "j2rp2" !! name of the j2rp2 variable + integer(I4B) :: j2rp2_varid !! ID for the j2 variable + character(NAMELEN) :: j4rp4_varname = "j4rp4" !! name of the j4pr4 variable + integer(I4B) :: j4rp4_varid !! ID for the j4 variable + character(NAMELEN) :: k2_varname = "k2" !! name of the Love number variable + integer(I4B) :: k2_varid !! ID for the Love number variable + character(NAMELEN) :: q_varname = "Q" !! name of the energy dissipation variable + integer(I4B) :: Q_varid !! ID for the energy dissipation variable + character(NAMELEN) :: ke_orb_varname = "KE_orb" !! name of the system orbital kinetic energy variable + integer(I4B) :: KE_orb_varid !! ID for the system orbital kinetic energy variable + character(NAMELEN) :: ke_spin_varname = "KE_spin" !! name of the system spin kinetic energy variable + integer(I4B) :: KE_spin_varid !! ID for the system spin kinetic energy variable + character(NAMELEN) :: pe_varname = "PE" !! name of the system potential energy variable + integer(I4B) :: PE_varid !! ID for the system potential energy variable + character(NAMELEN) :: L_orb_varname = "L_orb" !! name of the orbital angular momentum vector variable + integer(I4B) :: L_orb_varid !! ID for the system orbital angular momentum vector variable + character(NAMELEN) :: Lspin_varname = "Lspin" !! name of the spin angular momentum vector variable + integer(I4B) :: Lspin_varid !! ID for the system spin angular momentum vector variable + character(NAMELEN) :: L_escape_varname = "L_escape" !! name of the escaped angular momentum vector variable + integer(I4B) :: L_escape_varid !! ID for the escaped angular momentum vector variable + character(NAMELEN) :: Ecollisions_varname = "Ecollisions" !! name of the escaped angular momentum y variable + integer(I4B) :: Ecollisions_varid !! ID for the energy lost in collisions variable + character(NAMELEN) :: Euntracked_varname = "Euntracked" !! name of the energy that is untracked due to loss (untracked potential energy due to mergers and body energy for escaped bodies) + integer(I4B) :: Euntracked_varid !! ID for the energy that is untracked due to loss (untracked potential energy due to mergers and body energy for escaped bodies) + character(NAMELEN) :: GMescape_varname = "GMescape" !! name of the G*Mass of bodies that escape the system + integer(I4B) :: GMescape_varid !! ID for the G*Mass of bodies that escape the system + character(NAMELEN) :: origin_type_varname = "origin_type" !! name of the origin type variable (Initial Conditions, Disruption, etc.) + integer(I4B) :: origin_type_varid !! ID for the origin type + character(NAMELEN) :: origin_time_varname = "origin_time" !! name of the time of origin variable + integer(I4B) :: origin_time_varid !! ID for the origin time + character(NAMELEN) :: collision_id_varname = "collision_id" !! name of the collision id variable + integer(I4B) :: collision_id_varid !! Netcdf ID for the origin collision ID + character(NAMELEN) :: origin_rh_varname = "origin_rh" !! name of the heliocentric position vector of the body at the time of origin variable + integer(I4B) :: origin_rh_varid !! ID for the origin position vector variable + character(NAMELEN) :: origin_vh_varname = "origin_vh" !! name of the heliocentric velocity vector of the body at the time of origin variable + integer(I4B) :: origin_vh_varid !! ID for the origin velocity vector component + character(NAMELEN) :: discard_time_varname = "discard_time" !! name of the time of discard variable + integer(I4B) :: discard_time_varid !! ID for the time of discard variable + character(NAMELEN) :: discard_rh_varname = "discard_rh" !! name of the heliocentric position vector of the body at the time of discard variable + integer(I4B) :: discard_rh_varid !! ID for the heliocentric position vector of the body at the time of discard variable + character(NAMELEN) :: discard_vh_varname = "discard_vh" !! name of the heliocentric velocity vector of the body at the time of discard variable + integer(I4B) :: discard_vh_varid !! ID for the heliocentric velocity vector of the body at the time of discard variable + character(NAMELEN) :: discard_body_id_varname = "discard_body_id" !! name of the id of the other body involved in the discard + contains + procedure(abstract_io_netcdf_initialize_output), deferred :: initialize + procedure(abstract_io_netcdf_open), deferred :: open + procedure :: close => base_io_netcdf_close !! Closes an open NetCDF file + procedure :: flush => base_io_netcdf_flush !! Flushes the current buffer to disk by closing and re-opening the file. + procedure :: sync => base_io_netcdf_sync !! Syncrhonize the disk and memory buffer of the NetCDF file (e.g. commit the frame files stored in memory to disk) + end type base_io_netcdf_parameters + + abstract interface + subroutine abstract_io_netcdf_initialize_output(self, param) + import base_io_netcdf_parameters, base_parameters + implicit none + class(base_io_netcdf_parameters), intent(inout) :: self !! Parameters used to for writing a NetCDF dataset to file + class(base_parameters), intent(in) :: param !! Current run configuration parameters + end subroutine abstract_io_netcdf_initialize_output + end interface + + + type :: base_storage_frame + class(*), allocatable :: item + contains + procedure :: store => copy_store !! Stores a snapshot of the nbody system so that later it can be retrieved for saving to file. + generic :: assignment(=) => store + final :: final_storage_frame + end type + + type, abstract :: base_storage(nframes) + !! An class that establishes the pattern for various storage objects + integer(I4B), len :: nframes = 4096 !! Total number of frames that can be stored + + !! An class that establishes the pattern for various storage objects + type(base_storage_frame), dimension(nframes) :: frame !! Array of stored frames + integer(I4B) :: iframe = 0 !! Index of the last frame stored in the system + integer(I4B) :: nid !! Number of unique id values in all saved snapshots + integer(I4B), dimension(:), allocatable :: idvals !! The set of unique id values contained in the snapshots + integer(I4B), dimension(:), allocatable :: idmap !! The id value -> index map + integer(I4B) :: nt !! Number of unique time values in all saved snapshots + real(DP), dimension(:), allocatable :: tvals !! The set of unique time values contained in the snapshots + integer(I4B), dimension(:), allocatable :: tmap !! The t value -> index map + class(base_io_netcdf_parameters), allocatable :: nc !! NetCDF object attached to this storage object + contains + procedure :: reset => reset_storage !! Resets a storage object by deallocating all items and resetting the frame counter to 0 + end type base_storage + + + !> Class definition for the particle origin information object. This object is used to track time, location, and collisional regime + !> of fragments produced in collisional events. + type, abstract :: base_particle_info + end type base_particle_info + + + !> An abstract class for a generic collection of Swiftest bodies + type, abstract :: base_object + end type base_object + + type, abstract :: base_multibody(nbody) + integer(I4B), len :: nbody + integer(I4B), dimension(nbody) :: id + end type base_multibody + + !> Class definition for the kinship relationships used in bookkeeping multiple collisions bodies in a single time step. + type, abstract :: base_kinship + end type base_kinship + + + !> An abstract class for a basic Swiftest nbody system + type, abstract :: base_nbody_system + end type base_nbody_system + + abstract interface + subroutine abstract_io_netcdf_open(self, param, readonly) + import base_io_netcdf_parameters, base_parameters + implicit none + class(base_io_netcdf_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset + class(base_parameters), intent(in) :: param !! Current run configuration parameters + logical, optional, intent(in) :: readonly !! Logical flag indicating that this should be open read only + end subroutine abstract_io_netcdf_open + end interface + + contains + + subroutine copy_store(self, source) + !! author: David A. Minton + !! + !! Stores a snapshot of the nbody system so that later it can be retrieved for saving to file. + implicit none + class(base_storage_frame), intent(inout) :: self !! Swiftest storage frame object + class(*), intent(in) :: source !! Swiftest n-body system object + + if (allocated(self%item)) deallocate(self%item) + allocate(self%item, source=source) + + return + end subroutine copy_store + + + subroutine final_storage_frame(self) + !! author: David A. Minton + !! + !! Finalizer for the storage frame data type + implicit none + type(base_storage_frame) :: self + + if (allocated(self%item)) deallocate(self%item) + + return + end subroutine final_storage_frame + + subroutine netcdf_check(status, call_identifier) + !! author: Carlisle A. Wishard, Dana Singh, and David A. Minton + !! + !! Checks the status of all NetCDF operations to catch errors + use netcdf + implicit none + ! Arguments + integer, intent (in) :: status !! The status code returned by a NetCDF function + character(len=*), intent(in), optional :: call_identifier !! String that indicates which calling function caused the error for diagnostic purposes + + if(status /= nf90_noerr) then + if (present(call_identifier)) write(*,*) "NetCDF error in ",trim(call_identifier) + write(*,*) trim(nf90_strerror(status)) + call util_exit(FAILURE) + end if + + return + end subroutine netcdf_check + + + subroutine base_io_netcdf_close(self) + !! author: Carlisle A. Wishard, Dana Singh, and David A. Minton + !! + !! Closes a NetCDF file + use netcdf + implicit none + ! Arguments + class(base_io_netcdf_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset + + call netcdf_check( nf90_close(self%id), "base_io_netcdf_close" ) + + return + end subroutine base_io_netcdf_close + + + subroutine base_io_netcdf_flush(self, param) + !! author: David A. Minton + !! + !! Flushes the current buffer to disk by closing and re-opening the file. + !! + implicit none + ! Arguments + class(base_io_netcdf_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + + call self%close() + call self%open(param) + + return + end subroutine base_io_netcdf_flush + + + + subroutine base_io_netcdf_sync(self) + !! author: David A. Minton + !! + !! Syncrhonize the disk and memory buffer of the NetCDF file (e.g. commit the frame files stored in memory to disk) + !! + use netcdf + implicit none + ! Arguments + class(base_io_netcdf_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset + + call netcdf_check( nf90_sync(self%id), "base_io_netcdf_sync nf90_sync" ) + + return + end subroutine base_io_netcdf_sync + + + + subroutine base_util_final_storage(self) + !! author: David A. Minton + !! + !! Finalizer for the storage object + implicit none + ! Arguments + class(base_storage(*)), intent(inout) :: self + ! Internals + integer(I4B) :: i + + do i = 1, self%nframes + call final_storage_frame(self%frame(i)) + end do + return + end subroutine base_util_final_storage + + + subroutine reset_storage(self) + !! author: David A. Minton + !! + !! Resets a storage object by deallocating all items and resetting the frame counter to 0 + implicit none + ! Arguments + class(base_storage(*)), intent(inout) :: self !! Swiftest storage object + ! Internals + integer(I4B) :: i + + do i = 1, self%nframes + if (allocated(self%frame(i)%item)) deallocate(self%frame(i)%item) + end do + + if (allocated(self%idmap)) deallocate(self%idmap) + if (allocated(self%tmap)) deallocate(self%tmap) + self%nid = 0 + self%nt = 0 + self%iframe = 0 + + return + end subroutine reset_storage + +end module base diff --git a/src/modules/collision.f90 b/src/modules/collision.f90 new file mode 100644 index 000000000..bee281fd3 --- /dev/null +++ b/src/modules/collision.f90 @@ -0,0 +1,406 @@ +!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh +!! This file is part of Swiftest. +!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License +!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. +!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty +!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. +!! You should have received a copy of the GNU General Public License along with Swiftest. +!! If not, see: https://www.gnu.org/licenses. + +module collision + !! author: The Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott + !! + !! Definition of classes and methods used to determine close encounters + use globals + use base + use encounter + implicit none + public + + !>Symbolic names for collisional outcomes from collresolve_resolve: + integer(I4B), parameter :: COLLRESOLVE_REGIME_MERGE = 1 + integer(I4B), parameter :: COLLRESOLVE_REGIME_DISRUPTION = 2 + integer(I4B), parameter :: COLLRESOLVE_REGIME_SUPERCATASTROPHIC = 3 + integer(I4B), parameter :: COLLRESOLVE_REGIME_GRAZE_AND_MERGE = 4 + integer(I4B), parameter :: COLLRESOLVE_REGIME_HIT_AND_RUN = 5 + character(len=*),dimension(5), parameter :: REGIME_NAMES = ["Merge", "Disruption", "Supercatastrophic", "Graze and Merge", "Hit and Run"] + + !> Swiftest class for tracking pl-pl close encounters in a step when collisions are possible + type, extends(encounter_list) :: collision_list_plpl + contains + procedure :: extract_collisions => collision_resolve_extract_plpl !! Processes the pl-pl encounter list remove only those encounters that led to a collision + procedure :: collision_check => collision_check_plpl !! Checks if a test particle is going to collide with a massive body + procedure :: resolve_collision => collision_resolve_plpl !! Process the pl-pl collision list, then modifiy the massive bodies based on the outcome of the collision + end type collision_list_plpl + + + !> Class for tracking pl-tp close encounters in a step when collisions are possible + type, extends(encounter_list) :: collision_list_pltp + contains + procedure :: extract_collisions => collision_resolve_extract_pltp !! Processes the pl-tp encounter list remove only those encounters that led to a collision + procedure :: collision_check => collision_check_pltp !! Checks if a test particle is going to collide with a massive body + procedure :: resolve_collision => collision_resolve_pltp !! Process the pl-tp collision list + end type collision_list_pltp + + + !> Class definition for the variables that describe the bodies involved in the collision + type, extends(base_object) :: collision_impactors + integer(I4B) :: ncoll !! Number of bodies involved in the collision + integer(I4B), dimension(:), allocatable :: id !! Index of bodies involved in the collision + real(DP), dimension(NDIM,2) :: rb !! Two-body equivalent position vectors of the collider bodies prior to collision + real(DP), dimension(NDIM,2) :: vb !! Two-body equivalent velocity vectors of the collider bodies prior to collision + real(DP), dimension(NDIM,2) :: rot !! Two-body equivalent principal axes moments of inertia the collider bodies prior to collision + real(DP), dimension(NDIM,2) :: Lspin !! Two-body equivalent spin angular momentum vectors of the collider bodies prior to collision + real(DP), dimension(NDIM,2) :: Lorbit !! Two-body equivalent orbital angular momentum vectors of the collider bodies prior to collision + real(DP), dimension(NDIM,2) :: Ip !! Two-body equivalent principal axes moments of inertia the collider bodies prior to collision + real(DP), dimension(2) :: mass !! Two-body equivalent mass of the collider bodies prior to the collision + real(DP), dimension(2) :: radius !! Two-body equivalent radii of the collider bodies prior to the collision + real(DP) :: Qloss !! Energy lost during the collision + integer(I4B) :: regime !! Collresolve regime code for this collision + real(DP), dimension(:), allocatable :: mass_dist !! Distribution of fragment mass determined by the regime calculation (largest fragment, second largest, and remainder) + real(DP) :: Mcb !! Mass of central body (used to compute potential energy in regime determination) + + ! Values in a coordinate frame centered on the collider barycenter and collisional system unit vectors + real(DP), dimension(NDIM) :: x_unit !! x-direction unit vector of collisional system + real(DP), dimension(NDIM) :: y_unit !! y-direction unit vector of collisional system + real(DP), dimension(NDIM) :: z_unit !! z-direction unit vector of collisional system + real(DP), dimension(NDIM) :: v_unit !! z-direction unit vector of collisional system + real(DP), dimension(NDIM) :: rbcom !! Center of mass position vector of the collider system in system barycentric coordinates + real(DP), dimension(NDIM) :: vbcom !! Velocity vector of the center of mass of the collider system in system barycentric coordinates + real(DP), dimension(NDIM) :: rbimp !! Impact point position vector of the collider system in system barycentric coordinates + + contains + procedure :: get_regime => collision_regime_impactors !! Determine which fragmentation regime the set of impactors will be + procedure :: reset => collision_util_reset_impactors !! Resets the collider object variables to 0 and deallocates the index and mass distributions + final :: collision_util_final_impactors !! Finalizer will deallocate all allocatables + end type collision_impactors + + + !> Class definition for the variables that describe a collection of fragments in barycentric coordinates + type, extends(base_multibody) :: collision_fragments + real(DP) :: mtot !! Total mass of fragments + class(base_particle_info), dimension(:), allocatable :: info !! Particle metadata information + integer(I4B), dimension(nbody) :: status !! An integrator-specific status indicator + real(DP), dimension(NDIM,nbody) :: rh !! Heliocentric position + real(DP), dimension(NDIM,nbody) :: vh !! Heliocentric velocity + real(DP), dimension(NDIM,nbody) :: rb !! Barycentric position + real(DP), dimension(NDIM,nbody) :: vb !! Barycentric velocity + real(DP), dimension(NDIM,nbody) :: rot !! rotation vectors of fragments + real(DP), dimension(NDIM,nbody) :: Ip !! Principal axes moment of inertia for fragments + real(DP), dimension(nbody) :: mass !! masses of fragments + real(DP), dimension(nbody) :: radius !! Radii of fragments + real(DP), dimension(nbody) :: density !! Radii of fragments + real(DP), dimension(NDIM,nbody) :: rc !! Position vectors in the collision coordinate frame + real(DP), dimension(NDIM,nbody) :: vc !! Velocity vectors in the collision coordinate frame + real(DP), dimension(nbody) :: rmag !! Array of radial distance magnitudes of individual fragments in the collisional coordinate frame + real(DP), dimension(nbody) :: vmag !! Array of radial distance magnitudes of individual fragments in the collisional coordinate frame + real(DP), dimension(nbody) :: rotmag !! Array of rotation magnitudes of individual fragments + real(DP), dimension(NDIM,nbody) :: v_r_unit !! Array of radial direction unit vectors of individual fragments in the collisional coordinate frame + real(DP), dimension(NDIM,nbody) :: v_t_unit !! Array of tangential direction unit vectors of individual fragments in the collisional coordinate frame + real(DP), dimension(NDIM,nbody) :: v_n_unit !! Array of normal direction unit vectors of individual fragments in the collisional coordinate frame + contains + procedure :: reset => collision_util_reset_fragments !! Deallocates all allocatable arrays and sets everything else to 0 + final :: collision_util_final_fragments !! Finalizer deallocates all allocatables + end type collision_fragments + + + type :: collision_system + !! This class defines a collisional system that stores impactors and fragments. This is written so that various collision models (i.e. Fraggle) could potentially be used + !! to resolve collision by defining extended types of encounters_impactors and/or encounetr_fragments + class(collision_fragments(:)), allocatable :: fragments !! Object containing information on the pre-collision system + class(collision_impactors), allocatable :: impactors !! Object containing information on the post-collision system + class(base_nbody_system), allocatable :: before !! A snapshot of the subset of the system involved in the collision + class(base_nbody_system), allocatable :: after !! A snapshot of the subset of the system containing products of the collision + + ! For the following variables, index 1 refers to the *entire* n-body system in its pre-collisional state and index 2 refers to the system in its post-collisional state + real(DP), dimension(NDIM,2) :: Lorbit !! Before/after orbital angular momentum + real(DP), dimension(NDIM,2) :: Lspin !! Before/after spin angular momentum + real(DP), dimension(NDIM,2) :: Ltot !! Before/after total system angular momentum + real(DP), dimension(2) :: ke_orbit !! Before/after orbital kinetic energy + real(DP), dimension(2) :: ke_spin !! Before/after spin kinetic energy + real(DP), dimension(2) :: pe !! Before/after potential energy + real(DP), dimension(2) :: Etot !! Before/after total system energy + contains + procedure :: generate_fragments => abstract_generate_fragments !! Generates a system of fragments + procedure :: set_mass_dist => abstract_set_mass_dist !! Sets the distribution of mass among the fragments depending on the regime type + procedure :: setup => collision_setup_system !! Initializer for the encounter collision system and the before/after snapshots + procedure :: setup_impactors => collision_setup_impactors_system !! Initializer for the impactors for the encounter collision system. Deallocates old impactors before creating new ones + procedure :: setup_fragments => collision_setup_fragments_system !! Initializer for the fragments of the collision system. + procedure :: add_fragments => collision_util_add_fragments_to_system !! Add fragments to system + procedure :: construct_temporary_system => collision_util_construct_temporary_system !! Constructs temporary n-body system in order to compute pre- and post-impact energy and momentum + procedure :: get_energy_and_momentum => collision_util_get_energy_momentum !! Calculates total system energy in either the pre-collision outcome state (lbefore = .true.) or the post-collision outcome state (lbefore = .false.) + procedure :: reset => collision_util_reset_system !! Deallocates all allocatables + procedure :: set_coordinate_system => collision_util_set_coordinate_system !! Sets the coordinate system of the collisional system + final :: collision_util_final_system !! Finalizer will deallocate all allocatables + end type collision_system + + + !! NetCDF dimension and variable names for the enounter save object + type, extends(encounter_io_parameters) :: collision_io_parameters + integer(I4B) :: stage_dimid !! ID for the stage dimension + integer(I4B) :: stage_varid !! ID for the stage variable + character(NAMELEN) :: stage_dimname = "stage" !! name of the stage dimension (before/after) + character(len=6), dimension(2) :: stage_coords = ["before", "after"] !! The stage coordinate labels + + character(NAMELEN) :: event_dimname = "collision" !! Name of collision event dimension + integer(I4B) :: event_dimid !! ID for the collision event dimension + integer(I4B) :: event_varid !! ID for the collision event variable + integer(I4B) :: event_dimsize = 0 !! Number of events + + character(NAMELEN) :: Qloss_varname = "Qloss" !! name of the energy loss variable + integer(I4B) :: Qloss_varid !! ID for the energy loss variable + character(NAMELEN) :: regime_varname = "regime" !! name of the collision regime variable + integer(I4B) :: regime_varid !! ID for the collision regime variable + contains + procedure :: initialize => collision_io_initialize_output !! Initialize a set of parameters used to identify a NetCDF output object + end type collision_io_parameters + + + type, extends(encounter_snapshot) :: collision_snapshot + logical :: lcollision !! Indicates that this snapshot contains at least one collision + class(collision_system), allocatable :: collision_system !! impactors object at this snapshot + contains + procedure :: write_frame => collision_io_write_frame_snapshot !! Writes a frame of encounter data to file + procedure :: get_idvals => collision_util_get_idvalues_snapshot !! Gets an array of all id values saved in this snapshot + final :: collision_util_final_snapshot !! Finalizer deallocates all allocatables + end type collision_snapshot + + + !> A class that that is used to store simulation history data between file output + type, extends(encounter_storage) :: collision_storage + contains + procedure :: dump => collision_io_dump !! Dumps contents of encounter history to file + procedure :: take_snapshot => collision_util_snapshot !! Take a minimal snapshot of the system through an encounter + procedure :: make_index_map => collision_util_index_map !! Maps body id values to storage index values so we don't have to use unlimited dimensions for id + final :: collision_util_final_storage !! Finalizer deallocates all allocatables + end type collision_storage + + + abstract interface + subroutine abstract_generate_fragments(self, system, param, lfailure) + import collision_system, base_nbody_system, base_parameters + implicit none + class(collision_system), intent(inout) :: self !! Collision system object + class(base_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + logical, intent(out) :: lfailure !! Answers the question: Should this have been a merger instead? + end subroutine abstract_generate_fragments + + subroutine abstract_set_mass_dist(self, param) + import collision_system, base_parameters + implicit none + class(collision_system), intent(inout) :: self !! Collision system object + class(base_parameters), intent(in) :: param !! Current Swiftest run configuration parameters + end subroutine abstract_set_mass_dist + end interface + + + interface + module subroutine collision_io_dump(self, param) + implicit none + class(collision_storage(*)), intent(inout) :: self !! Collision storage object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine collision_io_dump + + module subroutine collision_io_initialize_output(self, param) + implicit none + class(collision_io_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset + class(base_parameters), intent(in) :: param !! Current run configuration parameters + end subroutine collision_io_initialize_output + + module subroutine collision_io_write_frame_snapshot(self, history, param) + implicit none + class(collision_snapshot), intent(in) :: self !! Swiftest encounter structure + class(encounter_storage(*)), intent(inout) :: history !! Collision history object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine collision_io_write_frame_snapshot + + module subroutine collision_regime_impactors(self, system, param) + implicit none + class(collision_impactors), intent(inout) :: self !! Collision system impactors object + class(base_nbody_system), intent(in) :: system !! Swiftest nbody system object + class(base_parameters), intent(in) :: param !! Current Swiftest run configuration parameters + end subroutine collision_regime_impactors + + module subroutine collision_check_plpl(self, system, param, t, dt, irec, lany_collision) + implicit none + class(collision_list_plpl), intent(inout) :: self !! encounter list object + class(base_nbody_system), intent(inout) :: system !! SyMBA nbody system object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + real(DP), intent(in) :: t !! current time + real(DP), intent(in) :: dt !! step size + integer(I4B), intent(in) :: irec !! Current recursion level + logical, intent(out) :: lany_collision !! Returns true if any pair of encounters resulted in a collision + end subroutine collision_check_plpl + + module subroutine collision_check_pltp(self, system, param, t, dt, irec, lany_collision) + implicit none + class(collision_list_pltp), intent(inout) :: self !! encounter list object + class(base_nbody_system), intent(inout) :: system !! SyMBA nbody system object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + real(DP), intent(in) :: t !! current time + real(DP), intent(in) :: dt !! step size + integer(I4B), intent(in) :: irec !! Current recursion level + logical, intent(out) :: lany_collision !! Returns true if any pair of encounters resulted in a collision + end subroutine collision_check_pltp + + module subroutine collision_resolve_extract_plpl(self, system, param) + implicit none + class(collision_list_plpl), intent(inout) :: self !! pl-pl encounter list + class(base_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(base_parameters), intent(in) :: param !! Current run configuration parameters + end subroutine collision_resolve_extract_plpl + + module subroutine collision_resolve_extract_pltp(self, system, param) + implicit none + class(collision_list_pltp), intent(inout) :: self !! pl-tp encounter list + class(base_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(base_parameters), intent(in) :: param !! Current run configuration parameters + end subroutine collision_resolve_extract_pltp + + module subroutine collision_resolve_make_impactors_pl(pl, idx) + implicit none + class(base_object), intent(inout) :: pl !! Massive body object + integer(I4B), dimension(:), intent(in) :: idx !! Array holding the indices of the two bodies involved in the collision + end subroutine collision_resolve_make_impactors_pl + + module function collision_resolve_merge(system, param, t) result(status) + implicit none + class(base_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions + real(DP), intent(in) :: t !! Time of collision + integer(I4B) :: status !! Status flag assigned to this outcome + end function collision_resolve_merge + + + module subroutine collision_resolve_plpl(self, system, param, t, dt, irec) + implicit none + class(collision_list_plpl), intent(inout) :: self !! pl-pl encounter list + class(base_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters with Swiftest additions + real(DP), intent(in) :: t !! Current simulation time + real(DP), intent(in) :: dt !! Current simulation step size + integer(I4B), intent(in) :: irec !! Current recursion level + end subroutine collision_resolve_plpl + + module subroutine collision_resolve_pltp(self, system, param, t, dt, irec) + implicit none + class(collision_list_pltp), intent(inout) :: self !! pl-tp encounter list + class(base_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters with Swiftest additions + real(DP), intent(in) :: t !! Current simulation time + real(DP), intent(in) :: dt !! Current simulation step size + integer(I4B), intent(in) :: irec !! Current recursion level + end subroutine collision_resolve_pltp + + module subroutine collision_util_set_coordinate_system(self) + implicit none + class(collision_system), intent(inout) :: self !! Collisional system + end subroutine collision_util_set_coordinate_system + + module subroutine collision_setup_system(self, nbody_system) + implicit none + class(collision_system), intent(inout) :: self !! Encounter collision system object + class(base_nbody_system), intent(in) :: nbody_system !! Current nbody system. Used as a mold for the before/after snapshots + end subroutine collision_setup_system + + module subroutine collision_setup_impactors_system(self) + implicit none + class(collision_system), intent(inout) :: self !! Encounter collision system object + end subroutine collision_setup_impactors_system + + module subroutine collision_setup_fragments_system(self, nfrag) + implicit none + class(collision_system), intent(inout) :: self !! Encounter collision system object + integer(I4B), intent(in) :: nfrag !! Number of fragments to create + end subroutine collision_setup_fragments_system + + module subroutine collision_util_add_fragments_to_system(self, system, param) + implicit none + class(collision_system), intent(in) :: self !! Collision system system object + class(base_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(base_parameters), intent(in) :: param !! Current swiftest run configuration parameters + end subroutine collision_util_add_fragments_to_system + + module subroutine collision_util_construct_temporary_system(self, nbody_system, param, tmpsys, tmpparam) + implicit none + class(collision_system), intent(inout) :: self !! Collision system object + class(base_nbody_system), intent(in) :: nbody_system !! Original swiftest nbody system object + class(base_parameters), intent(in) :: param !! Current swiftest run configuration parameters + class(base_nbody_system), allocatable, intent(out) :: tmpsys !! Output temporary swiftest nbody system object + class(base_parameters), allocatable, intent(out) :: tmpparam !! Output temporary configuration run parameters + end subroutine collision_util_construct_temporary_system + + module subroutine collision_util_reset_fragments(self) + implicit none + class(collision_fragments(*)), intent(inout) :: self + end subroutine collision_util_reset_fragments + + module subroutine collision_util_final_fragments(self) + implicit none + type(collision_fragments(*)), intent(inout) :: self + end subroutine collision_util_final_fragments + + module subroutine collision_util_final_impactors(self) + implicit none + type(collision_impactors), intent(inout) :: self !! Collision impactors storage object + end subroutine collision_util_final_impactors + + module subroutine collision_util_final_storage(self) + implicit none + type(collision_storage(*)), intent(inout) :: self !! Swiftest nbody system object + end subroutine collision_util_final_storage + + module subroutine collision_util_final_snapshot(self) + implicit none + type(collision_snapshot), intent(inout) :: self !! Fraggle storage snapshot object + end subroutine collision_util_final_snapshot + + module subroutine collision_util_final_system(self) + implicit none + type(collision_system), intent(inout) :: self !! Collision system object + end subroutine collision_util_final_system + + module subroutine collision_util_get_idvalues_snapshot(self, idvals) + implicit none + class(collision_snapshot), intent(in) :: self !! Fraggle snapshot object + integer(I4B), dimension(:), allocatable, intent(out) :: idvals !! Array of all id values saved in this snapshot + end subroutine collision_util_get_idvalues_snapshot + + module subroutine collision_util_get_energy_momentum(self, system, param, lbefore) + use base, only : base_nbody_system, base_parameters + implicit none + class(collision_system), intent(inout) :: self !! Encounter collision system object + class(base_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(base_parameters), intent(inout) :: param !! Current swiftest run configuration parameters + logical, intent(in) :: lbefore !! Flag indicating that this the "before" state of the system, with impactors included and fragments excluded or vice versa + end subroutine collision_util_get_energy_momentum + + module subroutine collision_util_index_map(self) + implicit none + class(collision_storage(*)), intent(inout) :: self !! Collision storage object + end subroutine collision_util_index_map + + module subroutine collision_util_reset_impactors(self) + implicit none + class(collision_impactors), intent(inout) :: self !! Collision system object + end subroutine collision_util_reset_impactors + + module subroutine collision_util_reset_system(self) + implicit none + class(collision_system), intent(inout) :: self !! Collision system object + end subroutine collision_util_reset_system + + module subroutine collision_util_snapshot(self, param, system, t, arg) + implicit none + class(collision_storage(*)), intent(inout) :: self !! Swiftest storage object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + class(base_nbody_system), intent(inout) :: system !! Swiftest nbody system object to store + real(DP), intent(in), optional :: t !! Time of snapshot if different from system time + character(*), intent(in), optional :: arg !! "before": takes a snapshot just before the collision. "after" takes the snapshot just after the collision. + end subroutine collision_util_snapshot + end interface + + +end module collision + diff --git a/src/modules/collision_classes.f90 b/src/modules/collision_classes.f90 deleted file mode 100644 index 791542ffd..000000000 --- a/src/modules/collision_classes.f90 +++ /dev/null @@ -1,341 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -module collision_classes - !! author: The Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott - !! - !! Definition of classes and methods used to determine close encounters - use swiftest_globals - use swiftest_classes, only : swiftest_parameters, swiftest_nbody_system, swiftest_pl, swiftest_storage, netcdf_parameters - use encounter_classes, only : encounter_snapshot, encounter_io_parameters, encounter_storage, encounter_io_parameters - implicit none - public - - - !>Symbolic names for collisional outcomes from collresolve_resolve: - integer(I4B), parameter :: COLLRESOLVE_REGIME_MERGE = 1 - integer(I4B), parameter :: COLLRESOLVE_REGIME_DISRUPTION = 2 - integer(I4B), parameter :: COLLRESOLVE_REGIME_SUPERCATASTROPHIC = 3 - integer(I4B), parameter :: COLLRESOLVE_REGIME_GRAZE_AND_MERGE = 4 - integer(I4B), parameter :: COLLRESOLVE_REGIME_HIT_AND_RUN = 5 - character(len=*),dimension(5), parameter :: REGIME_NAMES = ["Merge", "Disruption", "Supercatastrophic", "Graze and Merge", "Hit and Run"] - - !******************************************************************************************************************************** - ! collision_impactors class definitions and method interfaces - !******************************************************************************************************************************* - !> Class definition for the variables that describe the bodies involved in the collision - type :: collision_impactors - integer(I4B) :: ncoll !! Number of bodies involved in the collision - integer(I4B), dimension(:), allocatable :: idx !! Index of bodies involved in the collision - real(DP), dimension(NDIM,2) :: rb !! Two-body equivalent position vectors of the collider bodies prior to collision - real(DP), dimension(NDIM,2) :: vb !! Two-body equivalent velocity vectors of the collider bodies prior to collision - real(DP), dimension(NDIM,2) :: rot !! Two-body equivalent principal axes moments of inertia the collider bodies prior to collision - real(DP), dimension(NDIM,2) :: Lspin !! Two-body equivalent spin angular momentum vectors of the collider bodies prior to collision - real(DP), dimension(NDIM,2) :: Lorbit !! Two-body equivalent orbital angular momentum vectors of the collider bodies prior to collision - real(DP), dimension(NDIM,2) :: Ip !! Two-body equivalent principal axes moments of inertia the collider bodies prior to collision - real(DP), dimension(2) :: mass !! Two-body equivalent mass of the collider bodies prior to the collision - real(DP), dimension(2) :: radius !! Two-body equivalent radii of the collider bodies prior to the collision - real(DP) :: Qloss !! Energy lost during the collision - integer(I4B) :: regime !! Collresolve regime code for this collision - real(DP), dimension(:), allocatable :: mass_dist !! Distribution of fragment mass determined by the regime calculation (largest fragment, second largest, and remainder) - - ! Values in a coordinate frame centered on the collider barycenter and collisional system unit vectors - real(DP), dimension(NDIM) :: x_unit !! x-direction unit vector of collisional system - real(DP), dimension(NDIM) :: y_unit !! y-direction unit vector of collisional system - real(DP), dimension(NDIM) :: z_unit !! z-direction unit vector of collisional system - real(DP), dimension(NDIM) :: v_unit !! z-direction unit vector of collisional system - real(DP), dimension(NDIM) :: rbcom !! Center of mass position vector of the collider system in system barycentric coordinates - real(DP), dimension(NDIM) :: vbcom !! Velocity vector of the center of mass of the collider system in system barycentric coordinates - real(DP), dimension(NDIM) :: rbimp !! Impact point position vector of the collider system in system barycentric coordinates - - contains - procedure :: get_regime => collision_regime_impactors !! Determine which fragmentation regime the set of impactors will be - procedure :: setup => collision_setup_impactors !! Allocates arrays for n fragments in a fragment system. Passing n = 0 deallocates all arrays. - procedure :: reset => collision_util_reset_impactors !! Resets the collider object variables to 0 and deallocates the index and mass distributions - final :: collision_util_final_impactors !! Finalizer will deallocate all allocatables - end type collision_impactors - - !******************************************************************************************************************************** - ! collision_fragments class definitions and method interfaces - !******************************************************************************************************************************* - !> Class definition for the variables that describe a collection of fragments by Fraggle barycentric coordinates - type, abstract, extends(swiftest_pl) :: collision_fragments - real(DP) :: mtot !! Total mass of fragments - real(DP), dimension(:,:), allocatable :: rc !! Position vectors in the collision coordinate frame - real(DP), dimension(:,:), allocatable :: vc !! Velocity vectors in the collision coordinate frame - real(DP), dimension(:), allocatable :: rmag !! Array of radial distance magnitudes of individual fragments in the collisional coordinate frame - real(DP), dimension(:), allocatable :: vmag !! Array of radial distance magnitudes of individual fragments in the collisional coordinate frame - real(DP), dimension(:), allocatable :: rotmag !! Array of rotation magnitudes of individual fragments - real(DP), dimension(:,:), allocatable :: v_r_unit !! Array of radial direction unit vectors of individual fragments in the collisional coordinate frame - real(DP), dimension(:,:), allocatable :: v_t_unit !! Array of tangential direction unit vectors of individual fragments in the collisional coordinate frame - real(DP), dimension(:,:), allocatable :: v_n_unit !! Array of normal direction unit vectors of individual fragments in the collisional coordinate frame - - contains - procedure :: accel => collision_util_placeholder_accel !! Placeholder subroutine to fulfill requirement for an accel method - procedure :: kick => collision_util_placeholder_kick !! Placeholder subroutine to fulfill requirement for a kick method - procedure :: step => collision_util_placeholder_step !! Placeholder subroutine to fulfill requirement for a step method - procedure :: setup => collision_setup_fragments !! Allocates arrays for n fragments in a Fraggle system. Passing n = 0 deallocates all arrays. - procedure :: dealloc => collision_util_dealloc_fragments !! Deallocates all allocatable arrays - end type collision_fragments - - type :: collision_system - !! This class defines a collisional system that stores impactors and fragments. This is written so that various collision models (i.e. Fraggle) could potentially be used - !! to resolve collision by defining extended types of encounters_impactors and/or encounetr_fragments - class(collision_impactors), allocatable :: impactors !! Object containing information on the pre-collision system - class(collision_fragments), allocatable :: fragments !! Object containing information on the post-collision system - class(swiftest_nbody_system), allocatable :: before !! A snapshot of the subset of the system involved in the collision - class(swiftest_nbody_system), allocatable :: after !! A snapshot of the subset of the system containing products of the collision - - ! For the following variables, index 1 refers to the *entire* n-body system in its pre-collisional state and index 2 refers to the system in its post-collisional state - real(DP), dimension(NDIM,2) :: Lorbit !! Before/after orbital angular momentum - real(DP), dimension(NDIM,2) :: Lspin !! Before/after spin angular momentum - real(DP), dimension(NDIM,2) :: Ltot !! Before/after total system angular momentum - real(DP), dimension(2) :: ke_orbit !! Before/after orbital kinetic energy - real(DP), dimension(2) :: ke_spin !! Before/after spin kinetic energy - real(DP), dimension(2) :: pe !! Before/after potential energy - real(DP), dimension(2) :: Etot !! Before/after total system energy - contains - procedure :: generate_fragments => abstract_generate_fragments !! Generates a system of fragments - procedure :: set_mass_dist => abstract_set_mass_dist !! Sets the distribution of mass among the fragments depending on the regime type - procedure :: setup => collision_setup_system !! Initializer for the encounter collision system. Allocates the collider and fragments classes and the before/after snapshots - procedure :: add_fragments => collision_util_add_fragments_to_system !! Add fragments to system - procedure :: construct_temporary_system => collision_util_construct_temporary_system !! Constructs temporary n-body system in order to compute pre- and post-impact energy and momentum - procedure :: get_energy_and_momentum => collision_util_get_energy_momentum !! Calculates total system energy in either the pre-collision outcome state (lbefore = .true.) or the post-collision outcome state (lbefore = .false.) - procedure :: reset => collision_util_reset_system !! Deallocates all allocatables - procedure :: set_coordinate_system => collision_util_set_coordinate_system !! Sets the coordinate system of the collisional system - final :: collision_util_final_system !! Finalizer will deallocate all allocatables - end type collision_system - - abstract interface - subroutine abstract_generate_fragments(self, system, param, lfailure) - import collision_system, swiftest_nbody_system, swiftest_parameters - implicit none - class(collision_system), intent(inout) :: self !! Fraggle fragment system object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - logical, intent(out) :: lfailure !! Answers the question: Should this have been a merger instead? - end subroutine abstract_generate_fragments - - subroutine abstract_set_mass_dist(self, param) - import collision_system, swiftest_parameters - implicit none - class(collision_system), intent(inout) :: self !! Collision system object - class(swiftest_parameters), intent(in) :: param !! Current Swiftest run configuration parameters - end subroutine abstract_set_mass_dist - end interface - - !! NetCDF dimension and variable names for the enounter save object - type, extends(encounter_io_parameters) :: collision_io_parameters - integer(I4B) :: stage_dimid !! ID for the stage dimension - integer(I4B) :: stage_varid !! ID for the stage variable - character(NAMELEN) :: stage_dimname = "stage" !! name of the stage dimension (before/after) - character(len=6), dimension(2) :: stage_coords = ["before", "after"] !! The stage coordinate labels - - character(NAMELEN) :: event_dimname = "collision" !! Name of collision event dimension - integer(I4B) :: event_dimid !! ID for the collision event dimension - integer(I4B) :: event_varid !! ID for the collision event variable - integer(I4B) :: event_dimsize = 0 !! Number of events - - character(NAMELEN) :: Qloss_varname = "Qloss" !! name of the energy loss variable - integer(I4B) :: Qloss_varid !! ID for the energy loss variable - character(NAMELEN) :: regime_varname = "regime" !! name of the collision regime variable - integer(I4B) :: regime_varid !! ID for the collision regime variable - - contains - procedure :: initialize => collision_io_initialize_output !! Initialize a set of parameters used to identify a NetCDF output object - end type collision_io_parameters - - type, extends(encounter_snapshot) :: collision_snapshot - logical :: lcollision !! Indicates that this snapshot contains at least one collision - class(collision_system), allocatable :: collision_system !! impactors object at this snapshot - contains - procedure :: write_frame => collision_io_write_frame_snapshot !! Writes a frame of encounter data to file - procedure :: get_idvals => collision_util_get_idvalues_snapshot !! Gets an array of all id values saved in this snapshot - final :: collision_util_final_snapshot !! Finalizer deallocates all allocatables - end type collision_snapshot - - !> A class that that is used to store simulation history data between file output - type, extends(encounter_storage) :: collision_storage - contains - procedure :: dump => collision_io_dump !! Dumps contents of encounter history to file - procedure :: take_snapshot => collision_util_snapshot !! Take a minimal snapshot of the system through an encounter - procedure :: make_index_map => collision_util_index_map !! Maps body id values to storage index values so we don't have to use unlimited dimensions for id - final :: collision_util_final_storage !! Finalizer deallocates all allocatables - end type collision_storage - - interface - module subroutine collision_io_dump(self, param) - implicit none - class(collision_storage(*)), intent(inout) :: self !! Collision storage object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine collision_io_dump - - module subroutine collision_io_initialize_output(self, param) - implicit none - class(collision_io_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - end subroutine collision_io_initialize_output - - module subroutine collision_io_write_frame_snapshot(self, nc, param) - implicit none - class(collision_snapshot), intent(in) :: self !! Swiftest encounter structure - class(netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular encounter io NetCDF dataset - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine collision_io_write_frame_snapshot - - !> The following interfaces are placeholders intended to satisfy the required abstract methods given by the parent class - module subroutine collision_util_placeholder_accel(self, system, param, t, lbeg) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters - implicit none - class(collision_fragments), intent(inout) :: self !! Fraggle fragment system object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - real(DP), intent(in) :: t !! Current simulation time - logical, intent(in) :: lbeg !! Optional argument that determines whether or not this is the beginning or end of the step - end subroutine collision_util_placeholder_accel - - module subroutine collision_util_placeholder_kick(self, system, param, t, dt, lbeg) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters - implicit none - class(collision_fragments), intent(inout) :: self !! Fraggle fragment system object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system objec - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - real(DP), intent(in) :: t !! Current time - real(DP), intent(in) :: dt !! Stepsize - logical, intent(in) :: lbeg !! Logical flag indicating whether this is the beginning of the half step or not. - end subroutine collision_util_placeholder_kick - - module subroutine collision_util_placeholder_step(self, system, param, t, dt) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters - implicit none - class(collision_fragments), intent(inout) :: self !! Helio massive body particle object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - real(DP), intent(in) :: t !! Current simulation time - real(DP), intent(in) :: dt !! Stepsiz - end subroutine collision_util_placeholder_step - - module subroutine collision_regime_impactors(self, system, param) - implicit none - class(collision_impactors), intent(inout) :: self !! Collision system impactors object - class(swiftest_nbody_system), intent(in) :: system !! Swiftest nbody system object - class(swiftest_parameters), intent(in) :: param !! Current Swiftest run configuration parameters - end subroutine collision_regime_impactors - - module subroutine collision_util_set_coordinate_system(self) - implicit none - class(collision_system), intent(inout) :: self !! Collisional system - end subroutine collision_util_set_coordinate_system - - module subroutine collision_setup_fragments(self, n, param) - implicit none - class(collision_fragments), intent(inout) :: self !! Fragment system object - integer(I4B), intent(in) :: n !! Number of fragments - class(swiftest_parameters), intent(in) :: param !! Current swiftest run configuration parameters - end subroutine collision_setup_fragments - - module subroutine collision_setup_impactors(self, system, param) - implicit none - class(collision_impactors), intent(inout) :: self !! Fragment system object - class(swiftest_nbody_system), intent(in) :: system - class(swiftest_parameters), intent(in) :: param !! Current swiftest run configuration parameters - end subroutine collision_setup_impactors - - module subroutine collision_setup_system(self, param) - use swiftest_classes, only : swiftest_parameters - implicit none - class(collision_system), intent(inout) :: self !! Collision system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine collision_setup_system - - module subroutine collision_util_add_fragments_to_system(self, system, param) - implicit none - class(collision_system), intent(in) :: self !! Collision system system object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object - class(swiftest_parameters), intent(in) :: param !! Current swiftest run configuration parameters - end subroutine collision_util_add_fragments_to_system - - module subroutine collision_util_construct_temporary_system(self, nbody_system, param, tmpsys, tmpparam) - implicit none - class(collision_system), intent(inout) :: self !! Fraggle collision system object - class(swiftest_nbody_system), intent(in) :: nbody_system !! Original swiftest nbody system object - class(swiftest_parameters), intent(in) :: param !! Current swiftest run configuration parameters - class(swiftest_nbody_system), allocatable, intent(out) :: tmpsys !! Output temporary swiftest nbody system object - class(swiftest_parameters), allocatable, intent(out) :: tmpparam !! Output temporary configuration run parameters - end subroutine collision_util_construct_temporary_system - - module subroutine collision_util_dealloc_fragments(self) - implicit none - class(collision_fragments), intent(inout) :: self - end subroutine collision_util_dealloc_fragments - - module subroutine collision_util_final_impactors(self) - implicit none - type(collision_impactors), intent(inout) :: self !! Collision impactors storage object - end subroutine collision_util_final_impactors - - module subroutine collision_util_final_storage(self) - implicit none - type(collision_storage(*)), intent(inout) :: self !! SyMBA nbody system object - end subroutine collision_util_final_storage - - module subroutine collision_util_final_snapshot(self) - implicit none - type(collision_snapshot), intent(inout) :: self !! Fraggle storage snapshot object - end subroutine collision_util_final_snapshot - - module subroutine collision_util_final_system(self) - implicit none - type(collision_system), intent(inout) :: self !! Collision system object - end subroutine collision_util_final_system - - module subroutine collision_util_get_idvalues_snapshot(self, idvals) - implicit none - class(collision_snapshot), intent(in) :: self !! Fraggle snapshot object - integer(I4B), dimension(:), allocatable, intent(out) :: idvals !! Array of all id values saved in this snapshot - end subroutine collision_util_get_idvalues_snapshot - - module subroutine collision_util_get_energy_momentum(self, system, param, lbefore) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters - implicit none - class(collision_system), intent(inout) :: self !! Encounter collision system object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current swiftest run configuration parameters - logical, intent(in) :: lbefore !! Flag indicating that this the "before" state of the system, with impactors included and fragments excluded or vice versa - end subroutine collision_util_get_energy_momentum - - module subroutine collision_util_index_map(self) - implicit none - class(collision_storage(*)), intent(inout) :: self !! Collision storage object - end subroutine collision_util_index_map - - module subroutine collision_util_reset_impactors(self) - implicit none - class(collision_impactors), intent(inout) :: self !! Collision system object - end subroutine collision_util_reset_impactors - - module subroutine collision_util_reset_system(self, param) - implicit none - class(collision_system), intent(inout) :: self !! Collision system object - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - end subroutine collision_util_reset_system - - module subroutine collision_util_snapshot(self, param, system, t, arg) - implicit none - class(collision_storage(*)), intent(inout) :: self !! Swiftest storage object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object to store - real(DP), intent(in), optional :: t !! Time of snapshot if different from system time - character(*), intent(in), optional :: arg !! "before": takes a snapshot just before the collision. "after" takes the snapshot just after the collision. - end subroutine collision_util_snapshot - - end interface - -end module collision_classes - diff --git a/src/modules/encounter_classes.f90 b/src/modules/encounter.f90 similarity index 84% rename from src/modules/encounter_classes.f90 rename to src/modules/encounter.f90 index 164d97450..d47fca9ee 100644 --- a/src/modules/encounter_classes.f90 +++ b/src/modules/encounter.f90 @@ -7,32 +7,33 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -module encounter_classes +module encounter !! author: The Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott !! !! Definition of classes and methods used to determine close encounters - use swiftest_globals - use swiftest_classes, only : swiftest_parameters, swiftest_nbody_system, swiftest_cb, swiftest_tp, swiftest_pl, swiftest_storage, netcdf_parameters + use globals + use base implicit none public integer(I4B), parameter :: SWEEPDIM = 3 - type :: encounter_list - integer(I8B) :: nenc = 0 !! Total number of encounters - logical :: lcollision !! Indicates if the encounter resulted in at least one collision - real(DP) :: t !! Time of encounter - logical, dimension(:), allocatable :: lclosest !! indicates that thie pair of bodies is in currently at its closest approach point - logical, dimension(:), allocatable :: lvdotr !! relative vdotr flag - integer(I4B), dimension(:), allocatable :: status !! status of the interaction - integer(I4B), dimension(:), allocatable :: index1 !! position of the first body in the encounter - integer(I4B), dimension(:), allocatable :: index2 !! position of the second body in the encounter - integer(I4B), dimension(:), allocatable :: id1 !! id of the first body in the encounter - integer(I4B), dimension(:), allocatable :: id2 !! id of the second body in the encounter - real(DP), dimension(:,:), allocatable :: r1 !! the position of body 1 in the encounter - real(DP), dimension(:,:), allocatable :: r2 !! the position of body 2 in the encounter - real(DP), dimension(:,:), allocatable :: v1 !! the velocity of body 1 in the encounter - real(DP), dimension(:,:), allocatable :: v2 !! the velocity of body 2 in the encounter + type, abstract :: encounter_list + integer(I8B) :: nenc = 0 !! Total number of encounters + real(DP) :: t !! Time of encounter + logical :: lcollision !! Indicates if the encounter resulted in at least one collision + real(DP), dimension(:), allocatable :: tcollision!! Time of collision + logical, dimension(:), allocatable :: lclosest !! indicates that thie pair of bodies is in currently at its closest approach point + logical, dimension(:), allocatable :: lvdotr !! relative vdotr flag + integer(I4B), dimension(:), allocatable :: status !! status of the interaction + integer(I4B), dimension(:), allocatable :: index1 !! position of the first body in the encounter + integer(I4B), dimension(:), allocatable :: index2 !! position of the second body in the encounter + integer(I4B), dimension(:), allocatable :: id1 !! id of the first body in the encounter + integer(I4B), dimension(:), allocatable :: id2 !! id of the second body in the encounter + real(DP), dimension(:,:), allocatable :: r1 !! the position of body 1 in the encounter + real(DP), dimension(:,:), allocatable :: r2 !! the position of body 2 in the encounter + real(DP), dimension(:,:), allocatable :: v1 !! the velocity of body 1 in the encounter + real(DP), dimension(:,:), allocatable :: v2 !! the velocity of body 2 in the encounter contains procedure :: setup => encounter_setup_list !! A constructor that sets the number of encounters and allocates and initializes all arrays procedure :: append => encounter_util_append_list !! Appends elements from one structure to another @@ -40,23 +41,23 @@ module encounter_classes procedure :: dealloc => encounter_util_dealloc_list !! Deallocates all allocatables procedure :: spill => encounter_util_spill_list !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) procedure :: resize => encounter_util_resize_list !! Checks the current size of the encounter list against the required size and extends it by a factor of 2 more than requested if it is too small. - final :: encounter_util_final_list !! Finalize the encounter list - deallocates all allocatables end type encounter_list + type :: encounter_snapshot !! A simplified version of a SyMBA nbody system object for storing minimal snapshots of the system state during encounters - class(swiftest_pl), allocatable :: pl !! Massive body data structure - class(swiftest_tp), allocatable :: tp !! Test particle data structure + class(base_object), allocatable :: pl !! Massive body data structure + class(base_object), allocatable :: tp !! Test particle data structure real(DP) :: t !! Simulation time when snapshot was taken integer(I8B) :: iloop !! Loop number at time of snapshot contains - procedure :: write_frame => encounter_io_write_frame_snapshot !! Writes a frame of encounter data to file - procedure :: get_idvals => encounter_util_get_idvalues_snapshot !! Gets an array of all id values saved in this snapshot + procedure :: write_frame => encounter_io_write_frame_snapshot !! Writes a frame of encounter data to file + procedure :: get_idvals => encounter_util_get_idvalues_snapshot !! Gets an array of all id values saved in this snapshot final :: encounter_util_final_snapshot end type encounter_snapshot !> A class that that is used to store simulation history data between file output - type, extends(swiftest_storage) :: encounter_storage + type, extends(base_storage) :: encounter_storage contains procedure :: dump => encounter_io_dump !! Dumps contents of encounter history to file procedure :: get_index_values => encounter_util_get_vals_storage !! Gets the unique values of the indices of a storage object (i.e. body id or time value) @@ -66,7 +67,7 @@ module encounter_classes end type encounter_storage !> NetCDF dimension and variable names for the enounter save object - type, extends(netcdf_parameters) :: encounter_io_parameters + type, extends(base_io_netcdf_parameters) :: encounter_io_parameters character(NAMELEN) :: loop_varname = "loopnum" !! Loop number for encounter integer(I4B) :: loop_varid !! ID for the recursion level variable integer(I4B) :: time_dimsize = 0 !! Number of time values in snapshot @@ -74,6 +75,7 @@ module encounter_classes integer(I4B) :: file_number = 1 !! The number to append on the output file contains procedure :: initialize => encounter_io_initialize_output !! Initialize a set of parameters used to identify a NetCDF output object + procedure :: open => encounter_io_netcdf_open end type encounter_io_parameters type encounter_bounding_box_1D @@ -98,9 +100,9 @@ module encounter_classes interface module subroutine encounter_check_all_plpl(param, npl, x, v, renc, dt, nenc, index1, index2, lvdotr) - use swiftest_classes, only: swiftest_parameters + use base, only: base_parameters implicit none - class(swiftest_parameters), intent(inout) :: param !! Current Swiftest run configuration parameter5s + class(base_parameters), intent(inout) :: param !! Current Swiftest run configuration parameter5s integer(I4B), intent(in) :: npl !! Total number of massive bodies real(DP), dimension(:,:), intent(in) :: x !! Position vectors of massive bodies real(DP), dimension(:,:), intent(in) :: v !! Velocity vectors of massive bodies @@ -114,9 +116,9 @@ end subroutine encounter_check_all_plpl module subroutine encounter_check_all_plplm(param, nplm, nplt, xplm, vplm, xplt, vplt, rencm, renct, dt, & nenc, index1, index2, lvdotr) - use swiftest_classes, only: swiftest_parameters + use base, only: base_parameters implicit none - class(swiftest_parameters), intent(inout) :: param !! Current Swiftest run configuration parameter5s + class(base_parameters), intent(inout) :: param !! Current Swiftest run configuration parameter5s integer(I4B), intent(in) :: nplm !! Total number of fully interacting massive bodies integer(I4B), intent(in) :: nplt !! Total number of partially interacting masive bodies (GM < GMTINY) real(DP), dimension(:,:), intent(in) :: xplm !! Position vectors of fully interacting massive bodies @@ -133,9 +135,9 @@ module subroutine encounter_check_all_plplm(param, nplm, nplt, xplm, vplm, xplt, end subroutine encounter_check_all_plplm module subroutine encounter_check_all_pltp(param, npl, ntp, xpl, vpl, xtp, vtp, renc, dt, nenc, index1, index2, lvdotr) - use swiftest_classes, only: swiftest_parameters + use base, only: base_parameters implicit none - class(swiftest_parameters), intent(inout) :: param !! Current Swiftest run configuration parameter5s + class(base_parameters), intent(inout) :: param !! Current Swiftest run configuration parameter5s integer(I4B), intent(in) :: npl !! Total number of massive bodies integer(I4B), intent(in) :: ntp !! Total number of test particles real(DP), dimension(:,:), intent(in) :: xpl !! Position vectors of massive bodies @@ -163,7 +165,7 @@ end subroutine encounter_check_one module subroutine encounter_check_collapse_ragged_list(ragged_list, n1, nenc, index1, index2, lvdotr) implicit none - type(encounter_list), dimension(:), intent(in) :: ragged_list !! The ragged encounter list + class(encounter_list), dimension(:), intent(in) :: ragged_list !! The ragged encounter list integer(I4B), intent(in) :: n1 !! Number of bodies 1 integer(I8B), intent(out) :: nenc !! Total number of encountersj integer(I4B), dimension(:), allocatable, intent(out) :: index1 !! Array of indices for body 1 @@ -211,20 +213,27 @@ end subroutine encounter_check_sweep_aabb_single_list module subroutine encounter_io_dump(self, param) implicit none class(encounter_storage(*)), intent(inout) :: self !! Encounter storage object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(base_parameters), intent(inout) :: param !! Current run configuration parameters end subroutine encounter_io_dump module subroutine encounter_io_initialize_output(self, param) implicit none class(encounter_io_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset - class(swiftest_parameters), intent(in) :: param + class(base_parameters), intent(in) :: param end subroutine encounter_io_initialize_output - module subroutine encounter_io_write_frame_snapshot(self, nc, param) + module subroutine encounter_io_netcdf_open(self, param, readonly) implicit none - class(encounter_snapshot), intent(in) :: self !! Swiftest encounter structure - class(netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular encounter io NetCDF dataset - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(encounter_io_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset + class(base_parameters), intent(in) :: param !! Current run configuration parameters + logical, optional, intent(in) :: readonly !! Logical flag indicating that this should be open read only + end subroutine encounter_io_netcdf_open + + module subroutine encounter_io_write_frame_snapshot(self, history, param) + implicit none + class(encounter_snapshot), intent(in) :: self !! Swiftest encounter structure + class(encounter_storage(*)), intent(inout) :: history !! Encounter storage object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters end subroutine encounter_io_write_frame_snapshot module subroutine encounter_setup_aabb(self, n, n_last) @@ -268,11 +277,6 @@ module subroutine encounter_util_final_aabb(self) type(encounter_bounding_box_1D), intent(inout) :: self !!Bounding box structure along a single dimension end subroutine encounter_util_final_aabb - module subroutine encounter_util_final_list(self) - implicit none - type(encounter_list), intent(inout) :: self !! Swiftest encounter list object - end subroutine encounter_util_final_list - module subroutine encounter_util_final_snapshot(self) implicit none type(encounter_snapshot), intent(inout) :: self !! Encounter snapshot object @@ -309,8 +313,8 @@ end subroutine encounter_util_resize_list module subroutine encounter_util_snapshot(self, param, system, t, arg) implicit none class(encounter_storage(*)), intent(inout) :: self !! Swiftest storage object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object to store + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + class(base_nbody_system), intent(inout) :: system !! Swiftest nbody system object to store real(DP), intent(in), optional :: t !! Time of snapshot if different from system time character(*), intent(in), optional :: arg !! Optional argument (needed for extended storage type used in collision snapshots) end subroutine encounter_util_snapshot @@ -325,5 +329,5 @@ end subroutine encounter_util_spill_list end interface -end module encounter_classes +end module encounter diff --git a/src/modules/fraggle_classes.f90 b/src/modules/fraggle.f90 similarity index 61% rename from src/modules/fraggle_classes.f90 rename to src/modules/fraggle.f90 index de8542f67..6b336fff4 100644 --- a/src/modules/fraggle_classes.f90 +++ b/src/modules/fraggle.f90 @@ -7,46 +7,42 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -module fraggle_classes +module fraggle !! author: The Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott !! !! Definition of classes and methods specific to Fraggle: *Fragment* *g*eneration that conserves angular momentum (*L*) and energy (*E*) - use swiftest_globals - use swiftest_classes, only : swiftest_parameters, swiftest_nbody_system, swiftest_cb, swiftest_pl, swiftest_storage, netcdf_parameters - use encounter_classes, only : encounter_snapshot, encounter_io_parameters, encounter_storage - use collision_classes, only : collision_impactors, collision_fragments, collision_system + use globals + use base + use encounter + use collision implicit none public integer(I4B), parameter :: FRAGGLE_NMASS_DIST = 3 !! Number of mass bins returned by the regime calculation (largest fragment, second largest, and remainder) character(len=*), parameter :: FRAGGLE_LOG_OUT = "fraggle.log" !! Name of log file for Fraggle diagnostic information - !******************************************************************************************************************************** - ! fraggle_fragments class definitions and method interfaces - !******************************************************************************************************************************* + !> Class definition for the variables that describe a collection of fragments by Fraggle barycentric coordinates type, extends(collision_fragments) :: fraggle_fragments - real(DP), dimension(:), allocatable :: v_r_mag !! Array of radial direction velocity magnitudes of individual fragments - real(DP), dimension(:), allocatable :: v_t_mag !! Array of tangential direction velocity magnitudes of individual fragments - real(DP), dimension(:), allocatable :: v_n_mag !! Array of normal direction velocity magnitudes of individual fragments - real(DP), dimension(NDIM) :: Lorbit !! Orbital angular momentum vector of all fragments - real(DP), dimension(NDIM) :: Lspin !! Spin angular momentum vector of all fragments - real(DP) :: ke_orbit !! Orbital kinetic energy of all fragments - real(DP) :: ke_spin !! Spin kinetic energy of all fragments - real(DP) :: ke_budget !! Kinetic energy budget for computing fragment trajectories - real(DP), dimension(NDIM) :: L_budget !! Angular momentum budget for computing fragment trajectories + real(DP), dimension(nbody) :: v_r_mag !! Array of radial direction velocity magnitudes of individual fragments + real(DP), dimension(nbody) :: v_t_mag !! Array of tangential direction velocity magnitudes of individual fragments + real(DP), dimension(nbody) :: v_n_mag !! Array of normal direction velocity magnitudes of individual fragments + real(DP), dimension(NDIM) :: Lorbit !! Orbital angular momentum vector of all fragments + real(DP), dimension(NDIM) :: Lspin !! Spin angular momentum vector of all fragments + real(DP) :: ke_orbit !! Orbital kinetic energy of all fragments + real(DP) :: ke_spin !! Spin kinetic energy of all fragments + real(DP) :: ke_budget !! Kinetic energy budget for computing fragment trajectories + real(DP), dimension(NDIM) :: L_budget !! Angular momentum budget for computing fragment trajectories contains - procedure :: setup => fraggle_setup_fragments !! Allocates arrays for n fragments in a Fraggle system. Passing n = 0 deallocates all arrays. - procedure :: reset => fraggle_setup_reset_fragments !! Resets all position and velocity-dependent fragment quantities in order to do a fresh calculation (does not reset mass, radius, or other values that get set prior to the call to fraggle_generate) - procedure :: get_angular_momentum => fraggle_util_get_angular_momentum !! Calcualtes the current angular momentum of the fragments - procedure :: dealloc => fraggle_util_dealloc_fragments !! Deallocates all allocatables - procedure :: restructure => fraggle_util_restructure !! Restructure the inputs after a failed attempt failed to find a set of positions and velocities that satisfy the energy and momentum constraints - final :: fraggle_util_final_fragments !! Finalizer will deallocate all allocatables - + procedure :: get_angular_momentum => fraggle_util_get_angular_momentum !! Calcualtes the current angular momentum of the fragments + procedure :: reset => fraggle_util_reset_fragments !! Resets all position and velocity-dependent fragment quantities in order to do a fresh calculation (does not reset mass, radius, or other values that get set prior to the call to fraggle_generate) + procedure :: restructure => fraggle_util_restructure !! Restructure the inputs after a failed attempt failed to find a set of positions and velocities that satisfy the energy and momentum constraints + final :: fraggle_util_final_fragments !! Finalizer will deallocate all allocatables end type fraggle_fragments + type, extends(collision_system) :: fraggle_system ! Scale factors used to scale dimensioned quantities to a more "natural" system where important quantities (like kinetic energy, momentum) are of order ~1 real(DP) :: dscale = 1.0_DP !! Distance dimension scale factor @@ -61,18 +57,21 @@ module fraggle_classes procedure :: set_mass_dist => fraggle_set_mass_dist !! Sets the distribution of mass among the fragments depending on the regime type procedure :: set_natural_scale => fraggle_set_natural_scale_factors !! Scales dimenional quantities to ~O(1) with respect to the collisional system. procedure :: set_original_scale => fraggle_set_original_scale_factors !! Restores dimenional quantities back to the original system units + procedure :: setup_fragments => fraggle_setup_fragments_system !! Initializer for the fragments of the collision system. procedure :: construct_temporary_system => fraggle_util_construct_temporary_system !! Constructs temporary n-body system in order to compute pre- and post-impact energy and momentum + procedure :: reset => fraggle_util_reset_system !! Deallocates all allocatables final :: fraggle_util_final_system !! Finalizer will deallocate all allocatables end type fraggle_system interface + module subroutine fraggle_generate_fragments(self, system, param, lfailure) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters + use base, only : base_nbody_system, base_parameters implicit none class(fraggle_system), intent(inout) :: self !! Fraggle fragment system object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(base_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters logical, intent(out) :: lfailure !! Answers the question: Should this have been a merger instead? end subroutine fraggle_generate_fragments @@ -89,7 +88,7 @@ end subroutine fraggle_set_budgets module subroutine fraggle_set_mass_dist(self, param) implicit none class(fraggle_system), intent(inout) :: self !! Fraggle collision system object - class(swiftest_parameters), intent(in) :: param !! Current Swiftest run configuration parameters + class(base_parameters), intent(in) :: param !! Current Swiftest run configuration parameters end subroutine fraggle_set_mass_dist module subroutine fraggle_set_natural_scale_factors(self) @@ -97,43 +96,48 @@ module subroutine fraggle_set_natural_scale_factors(self) class(fraggle_system), intent(inout) :: self !! Fraggle collision system object end subroutine fraggle_set_natural_scale_factors + module function fraggle_resolve_disruption(system, param, t) result(status) + implicit none + class(base_nbody_system), intent(inout) :: system !! SyMBA nbody system object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions + real(DP), intent(in) :: t !! Time of collision + integer(I4B) :: status !! Status flag assigned to this outcome + end function fraggle_resolve_disruption + + module function fraggle_resolve_hitandrun(system, param, t) result(status) + implicit none + class(base_nbody_system), intent(inout) :: system !! SyMBA nbody system object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions + real(DP), intent(in) :: t !! Time of collision + integer(I4B) :: status !! Status flag assigned to this outcome + end function fraggle_resolve_hitandrun + module subroutine fraggle_set_original_scale_factors(self) implicit none class(fraggle_system), intent(inout) :: self !! Fraggle collision system object end subroutine fraggle_set_original_scale_factors - module subroutine fraggle_setup_fragments(self, n, param) + module subroutine fraggle_setup_fragments_system(self, nfrag) implicit none - class(fraggle_fragments), intent(inout) :: self - integer(I4B), intent(in) :: n - class(swiftest_parameters), intent(in) :: param - end subroutine fraggle_setup_fragments - - module subroutine fraggle_setup_reset_fragments(self) - implicit none - class(fraggle_fragments), intent(inout) :: self - end subroutine fraggle_setup_reset_fragments + class(fraggle_system), intent(inout) :: self !! Encounter collision system object + integer(I4B), intent(in) :: nfrag !! Number of fragments to create + end subroutine fraggle_setup_fragments_system module subroutine fraggle_util_get_angular_momentum(self) implicit none - class(fraggle_fragments), intent(inout) :: self !! Fraggle fragment system object + class(fraggle_fragments(*)), intent(inout) :: self !! Fraggle fragment system object end subroutine fraggle_util_get_angular_momentum module subroutine fraggle_util_construct_temporary_system(self, nbody_system, param, tmpsys, tmpparam) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters + use base, only : base_nbody_system, base_parameters implicit none class(fraggle_system), intent(inout) :: self !! Fraggle collision system object - class(swiftest_nbody_system), intent(in) :: nbody_system !! Original swiftest nbody system object - class(swiftest_parameters), intent(in) :: param !! Current swiftest run configuration parameters - class(swiftest_nbody_system), allocatable, intent(out) :: tmpsys !! Output temporary swiftest nbody system object - class(swiftest_parameters), allocatable, intent(out) :: tmpparam !! Output temporary configuration run parameters + class(base_nbody_system), intent(in) :: nbody_system !! Original swiftest nbody system object + class(base_parameters), intent(in) :: param !! Current swiftest run configuration parameters + class(base_nbody_system), allocatable, intent(out) :: tmpsys !! Output temporary swiftest nbody system object + class(base_parameters), allocatable, intent(out) :: tmpparam !! Output temporary configuration run parameters end subroutine fraggle_util_construct_temporary_system - module subroutine fraggle_util_dealloc_fragments(self) - implicit none - class(fraggle_fragments), intent(inout) :: self - end subroutine fraggle_util_dealloc_fragments - module subroutine fraggle_util_final_impactors(self) implicit none type(collision_impactors), intent(inout) :: self !! Fraggle impactors object @@ -141,7 +145,7 @@ end subroutine fraggle_util_final_impactors module subroutine fraggle_util_final_fragments(self) implicit none - type(fraggle_fragments), intent(inout) :: self !! Fraggle frgments object + type(fraggle_fragments(*)), intent(inout) :: self !! Fraggle frgments object end subroutine fraggle_util_final_fragments module subroutine fraggle_util_final_system(self) @@ -149,9 +153,19 @@ module subroutine fraggle_util_final_system(self) type(fraggle_system), intent(inout) :: self !! Collision system object end subroutine fraggle_util_final_system + module subroutine fraggle_util_reset_fragments(self) + implicit none + class(fraggle_fragments(*)), intent(inout) :: self + end subroutine fraggle_util_reset_fragments + + module subroutine fraggle_util_reset_system(self) + implicit none + class(fraggle_system), intent(inout) :: self !! Collision system object + end subroutine fraggle_util_reset_system + module subroutine fraggle_util_restructure(self, impactors, try, f_spin, r_max_start) implicit none - class(fraggle_fragments), intent(inout) :: self !! Fraggle fragment system object + class(fraggle_fragments(*)), intent(inout) :: self !! Fraggle fragment system object class(collision_impactors), intent(in) :: impactors !! Fraggle collider system object integer(I4B), intent(in) :: try !! The current number of times Fraggle has tried to find a solution real(DP), intent(inout) :: f_spin !! Fraction of energy/momentum that goes into spin. This decreases ater a failed attempt @@ -175,4 +189,4 @@ module function fraggle_util_vmag_to_vb(v_r_mag, v_r_unit, v_t_mag, v_t_unit, m_ end function fraggle_util_vmag_to_vb end interface -end module fraggle_classes \ No newline at end of file +end module fraggle \ No newline at end of file diff --git a/src/modules/swiftest_globals.f90 b/src/modules/globals.f90 similarity index 90% rename from src/modules/swiftest_globals.f90 rename to src/modules/globals.f90 index fb669b559..23162a872 100644 --- a/src/modules/swiftest_globals.f90 +++ b/src/modules/globals.f90 @@ -7,12 +7,12 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -module swiftest_globals +module globals !! author: David A. Minton !! graph: false !! !! Basic parameters, definitions, and global type definitions used throughout the Swiftest project - !! Adapted from David E. Kaufmann's Swifter routine: swiftest_globals.f90 and module_swifter.f90 + !! Adapted from David E. Kaufmann's Swifter routine: globals.f90 and module_swifter.f90 use, intrinsic :: iso_fortran_env ! Use the intrinsic kind definitions implicit none public @@ -45,14 +45,14 @@ module swiftest_globals !> Symbolic name for integrator types character(*), parameter :: UNKNOWN_INTEGRATOR = "UKNOWN INTEGRATOR" - character(*), parameter :: BS = "Bulirsch-Stoer" - character(*), parameter :: HELIO = "Democratic Heliocentric" - character(*), parameter :: RA15 = "Radau 15th order" - character(*), parameter :: TU4 = "T+U 4th order" - character(*), parameter :: WHM = "Wisdom-Holman Method" - character(*), parameter :: RMVS = "Regularized Mixed Variable Symplectic" - character(*), parameter :: SYMBA = "SyMBA" - character(*), parameter :: RINGMOONS = "SyMBA-RINGMOONS" + character(*), parameter :: INT_BS = "Bulirsch-Stoer" + character(*), parameter :: INT_HELIO = "Democratic Heliocentric" + character(*), parameter :: INT_RA15 = "Radau 15th order" + character(*), parameter :: INT_TU4 = "T+U 4th order" + character(*), parameter :: INT_WHM = "Wisdom-Holman Method" + character(*), parameter :: INT_RMVS = "Regularized Mixed Variable Symplectic" + character(*), parameter :: INT_SYMBA = "SyMBA" + character(*), parameter :: INT_RINGMOONS = "SyMBA-RINGMOONS" integer(I4B), parameter :: STRMAX = 512 !! Maximum size of character strings integer(I4B), parameter :: NAMELEN = 32 !! Maximum size of name strings @@ -86,12 +86,12 @@ module swiftest_globals integer(I4B), parameter :: DISCARDED_PLQ = -6 integer(I4B), parameter :: DISCARDED_DRIFTERR = -7 integer(I4B), parameter :: MERGED = -8 - integer(I4B), parameter :: DISRUPTION = -9 + integer(I4B), parameter :: DISRUPTED = -9 integer(I4B), parameter :: SUPERCATASTROPHIC = -10 integer(I4B), parameter :: GRAZE_AND_MERGE = -11 integer(I4B), parameter :: HIT_AND_RUN_DISRUPT = -12 integer(I4B), parameter :: HIT_AND_RUN_PURE = -13 - integer(I4B), parameter :: COLLISION = -14 + integer(I4B), parameter :: COLLIDED = -14 integer(I4B), parameter :: NEW_PARTICLE = -15 integer(I4B), parameter :: OLD_PARTICLE = -16 @@ -124,4 +124,4 @@ module swiftest_globals integer(I4B), parameter :: NDIM2 = 2 * NDIM !! 2x the number of dimensions real(DP), parameter :: VSMALL = 2 * epsilon(1._DP) !! Very small number used to prevent floating underflow -end module swiftest_globals +end module globals diff --git a/src/modules/helio_classes.f90 b/src/modules/helio.f90 similarity index 83% rename from src/modules/helio_classes.f90 rename to src/modules/helio.f90 index bad042664..8a93badae 100644 --- a/src/modules/helio_classes.f90 +++ b/src/modules/helio.f90 @@ -7,21 +7,17 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -module helio_classes +module helio !! author: The Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott !! !! Definition of classes and methods specific to the Democratic Heliocentric Method !! Adapted from David E. Kaufmann's Swifter routine: module_helio.f90 - use swiftest_globals - use swiftest_classes, only : swiftest_cb, swiftest_pl, swiftest_tp, swiftest_nbody_system - use whm_classes, only : whm_nbody_system + use swiftest + use whm implicit none public - !******************************************************************************************************************************** - ! helio_nbody_system class definitions and method interfaces - !******************************************************************************************************************************** type, extends(whm_nbody_system) :: helio_nbody_system contains procedure :: step => helio_step_system !! Advance the Helio nbody system forward in time by one step @@ -29,9 +25,7 @@ module helio_classes final :: helio_util_final_system !! Finalizes the Helio system object - deallocates all allocatables end type helio_nbody_system - !******************************************************************************************************************************** - ! helio_cb class definitions and method interfaces - !******************************************************************************************************************************* + !> Helio central body particle class type, extends(swiftest_cb) :: helio_cb real(DP), dimension(NDIM) :: ptbeg !! negative barycentric velocity of the central body at the beginning of time step @@ -39,9 +33,6 @@ module helio_classes contains end type helio_cb - !******************************************************************************************************************************** - ! helio_pl class definitions and method interfaces - !******************************************************************************************************************************* !! Helio massive body particle class type, extends(swiftest_pl) :: helio_pl @@ -56,9 +47,6 @@ module helio_classes final :: helio_util_final_pl !! Finalizes the Helio massive body object - deallocates all allocatables end type helio_pl - !******************************************************************************************************************************** - ! helio_tp class definitions and method interfaces - !******************************************************************************************************************************* !! Helio test particle class type, extends(swiftest_tp) :: helio_tp @@ -75,7 +63,6 @@ module helio_classes interface module subroutine helio_drift_body(self, system, param, dt) - use swiftest_classes, only : swiftest_body, swiftest_nbody_system, swiftest_parameters implicit none class(swiftest_body), intent(inout) :: self !! Swiftest massive body object class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object @@ -84,7 +71,6 @@ module subroutine helio_drift_body(self, system, param, dt) end subroutine helio_drift_body module subroutine helio_drift_pl(self, system, param, dt) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters implicit none class(helio_pl), intent(inout) :: self !! Helio massive body object class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object @@ -93,7 +79,6 @@ module subroutine helio_drift_pl(self, system, param, dt) end subroutine helio_drift_pl module subroutine helio_drift_tp(self, system, param, dt) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters implicit none class(helio_tp), intent(inout) :: self !! Helio massive body object class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object @@ -118,21 +103,18 @@ module subroutine helio_drift_linear_tp(self, cb, dt, lbeg) end subroutine helio_drift_linear_tp pure module subroutine helio_gr_kick_getacch_pl(self, param) - use swiftest_classes, only : swiftest_parameters implicit none class(helio_pl), intent(inout) :: self !! Helio massive body particle data structure class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters end subroutine helio_gr_kick_getacch_pl pure module subroutine helio_gr_kick_getacch_tp(self, param) - use swiftest_classes, only : swiftest_parameters implicit none class(helio_tp), intent(inout) :: self !! Helio massive body particle data structure class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters end subroutine helio_gr_kick_getacch_tp pure module subroutine helio_gr_p4_pl(self, system, param, dt) - use swiftest_classes, only : swiftest_parameters, swiftest_nbody_system implicit none class(helio_pl), intent(inout) :: self !! Swiftest particle object class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object @@ -141,7 +123,6 @@ pure module subroutine helio_gr_p4_pl(self, system, param, dt) end subroutine helio_gr_p4_pl pure module subroutine helio_gr_p4_tp(self, system, param, dt) - use swiftest_classes, only : swiftest_parameters, swiftest_nbody_system implicit none class(helio_tp), intent(inout) :: self !! Swiftest particle object class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object @@ -150,7 +131,6 @@ pure module subroutine helio_gr_p4_tp(self, system, param, dt) end subroutine helio_gr_p4_tp module subroutine helio_kick_getacch_pl(self, system, param, t, lbeg) - use swiftest_classes, only : swiftest_parameters, swiftest_nbody_system implicit none class(helio_pl), intent(inout) :: self !! Helio massive body object class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object @@ -160,7 +140,6 @@ module subroutine helio_kick_getacch_pl(self, system, param, t, lbeg) end subroutine helio_kick_getacch_pl module subroutine helio_kick_getacch_tp(self, system, param, t, lbeg) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters implicit none class(helio_tp), intent(inout) :: self !! Helio test particle object class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object @@ -170,7 +149,6 @@ module subroutine helio_kick_getacch_tp(self, system, param, t, lbeg) end subroutine helio_kick_getacch_tp module subroutine helio_kick_vb_pl(self, system, param, t, dt, lbeg) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters implicit none class(helio_pl), intent(inout) :: self !! Helio massive body object class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object @@ -181,7 +159,6 @@ module subroutine helio_kick_vb_pl(self, system, param, t, dt, lbeg) end subroutine helio_kick_vb_pl module subroutine helio_kick_vb_tp(self, system, param, t, dt, lbeg) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters implicit none class(helio_tp), intent(inout) :: self !! Helio test particle object class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object @@ -192,14 +169,12 @@ module subroutine helio_kick_vb_tp(self, system, param, t, dt, lbeg) end subroutine helio_kick_vb_tp module subroutine helio_setup_initialize_system(self, param) - use swiftest_classes, only : swiftest_parameters implicit none class(helio_nbody_system), intent(inout) :: self !! Helio nbody system object class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters end subroutine helio_setup_initialize_system module subroutine helio_step_pl(self, system, param, t, dt) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters implicit none class(helio_pl), intent(inout) :: self !! Helio massive body particle object class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system @@ -209,7 +184,6 @@ module subroutine helio_step_pl(self, system, param, t, dt) end subroutine helio_step_pl module subroutine helio_step_system(self, param, t, dt) - use swiftest_classes, only : swiftest_parameters implicit none class(helio_nbody_system), intent(inout) :: self !! Helio nbody system object class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters @@ -218,7 +192,6 @@ module subroutine helio_step_system(self, param, t, dt) end subroutine helio_step_system module subroutine helio_step_tp(self, system, param, t, dt) - use swiftest_classes, only : swiftest_cb, swiftest_parameters, swiftest_nbody_system implicit none class(helio_tp), intent(inout) :: self !! Helio test particle object class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object @@ -244,4 +217,4 @@ end subroutine helio_util_final_tp end interface -end module helio_classes +end module helio diff --git a/src/io/io_progress_bar.f90 b/src/modules/io_progress_bar.f90 similarity index 84% rename from src/io/io_progress_bar.f90 rename to src/modules/io_progress_bar.f90 index 9a49ff935..1e1067da7 100644 --- a/src/io/io_progress_bar.f90 +++ b/src/modules/io_progress_bar.f90 @@ -2,14 +2,14 @@ module io_progress_bar !! author: The Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott !! !! Definition of classes and methods used to determine close encounters - use swiftest_globals - use swiftest_classes + use globals + use base implicit none public character(len=1),parameter, private :: barchar = "#" !! The progress bar character - type :: progress_bar + type :: pbar !! author: David A. Minton !! !! Implements a class for a simple progress bar that can print on the screen. @@ -20,19 +20,19 @@ module io_progress_bar character(len=32) :: fmt !! The format string that is used to define the progress bar itself character(len=64) :: message !! The current message displayed at the end of the progress bar contains - procedure :: reset => io_pbar_reset !! Resets the progress bar to the beginning - procedure :: update => io_pbar_update !! Updates the progress bar with new values - end type progress_bar + procedure :: reset => io_progress_bar_reset !! Resets the progress bar to the beginning + procedure :: update => io_progress_bar_update !! Updates the progress bar with new values + end type pbar contains - subroutine io_pbar_reset(self, loop_length) + subroutine io_progress_bar_reset(self, loop_length) !! author: David A. Minton !! !! Resets the progress bar to the beginning implicit none ! Arguments - class(progress_bar),intent(inout) :: self !! The progress bar object + class(pbar),intent(inout) :: self !! The progress bar object integer(I8B), intent(in) :: loop_length !! The length of the loop that the progress bar is attached to ! Internals character(len=2) :: numchar @@ -53,16 +53,16 @@ subroutine io_pbar_reset(self, loop_length) write(*,fmt=self%fmt) char(13),self%barstr,trim(adjustl(self%message)) return - end subroutine io_pbar_reset + end subroutine io_progress_bar_reset - subroutine io_pbar_update(self,i,message) + subroutine io_progress_bar_update(self,i,message) !! author: David A. Minton !! !! Updates the progress bar with new values implicit none ! Arguments - class(progress_bar), intent(inout) :: self !! Progres bar object + class(pbar), intent(inout) :: self !! Progres bar object integer(I8B), intent(in) :: i !! The current loop index of the progress loop character(len=*), intent(in), optional :: message !! An optional message to display to the right of the progress bar ! Internals @@ -92,7 +92,7 @@ subroutine io_pbar_update(self,i,message) return - end subroutine io_pbar_update + end subroutine io_progress_bar_update end module io_progress_bar diff --git a/src/modules/lambda_function.f90 b/src/modules/lambda_function.f90 index 44b97dfcc..9f7a0ef70 100644 --- a/src/modules/lambda_function.f90 +++ b/src/modules/lambda_function.f90 @@ -130,7 +130,7 @@ module lambda_function !! end program usage !! ******************************************************************************************************************************************************************************************** - use swiftest_globals + use globals implicit none public diff --git a/src/modules/swiftest_operators.f90 b/src/modules/operators.f90 similarity index 99% rename from src/modules/swiftest_operators.f90 rename to src/modules/operators.f90 index 165c7b283..8c351236b 100644 --- a/src/modules/swiftest_operators.f90 +++ b/src/modules/operators.f90 @@ -7,14 +7,14 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -module swiftest_operators +module operators !! author: David A. Minton !! !! Custom operators, including !! A .cross. B = Cross product of A(1:NDIM) and B(1:NDIM) !! !! Each operator can also do element-wise computation on arrays of the form .mag. A(1:NDIM, 1:n) - use swiftest_globals + use globals implicit none public @@ -207,4 +207,4 @@ end function operator_unit_el_qp end interface -end module swiftest_operators +end module operators diff --git a/src/modules/rmvs_classes.f90 b/src/modules/rmvs.f90 similarity index 89% rename from src/modules/rmvs_classes.f90 rename to src/modules/rmvs.f90 index f8add18eb..b42e0a937 100644 --- a/src/modules/rmvs_classes.f90 +++ b/src/modules/rmvs.f90 @@ -7,13 +7,13 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -module rmvs_classes +module rmvs !! author: David A. Minton !! - !! Definition of classes and methods specific to the Regularized Mixed Variable Symplectic (RMVS) integrator + !! Definition of classes and methods specific to the Regularized Mixed Variable Symplectic (INT_RMVS) integrator !! Partially adapted from David E. Kaufmann's Swifter module: module_rmvs.f90 - use swiftest_globals - use whm_classes, only : whm_cb, whm_pl, whm_tp, whm_nbody_system + use swiftest + use whm implicit none public @@ -24,11 +24,9 @@ module rmvs_classes real(DP), private, parameter :: RHPSCALE = 1.0_DP real(DP), private, parameter :: FACQDT = 2.0_DP - !******************************************************************************************************************************** - ! rmvs_nbody_system class definitions and method interfaces - !******************************************************************************************************************************** + + !> In the RMVS integrator, pl-tp encounters are handeled, but not pl-pl type, extends(whm_nbody_system) :: rmvs_nbody_system - !> In the RMVS integrator, only test particles are discarded logical :: lplanetocentric = .false. !! Flag that indicates that the object is a planetocentric set of masive bodies used for close encounter calculations real(DP) :: rts !! fraction of Hill's sphere radius to use as radius of encounter region real(DP), dimension(:,:), allocatable :: vbeg !! Planet velocities at beginning ot step @@ -49,9 +47,7 @@ module rmvs_classes final :: rmvs_util_final_interp !! Finalizes the RMVS interpolated system variables object - deallocates all allocatables end type rmvs_interp - !******************************************************************************************************************************** - ! rmvs_cb class definitions and method interfaces - !******************************************************************************************************************************* + !> RMVS central body particle class type, extends(whm_cb) :: rmvs_cb type(rmvs_interp), dimension(:), allocatable :: outer !! interpolated heliocentric central body position for outer encounters @@ -62,9 +58,6 @@ module rmvs_classes final :: rmvs_util_final_cb !! Finalizes the RMVS central body object - deallocates all allocatables end type rmvs_cb - !******************************************************************************************************************************** - ! rmvs_tp class definitions and method interfaces - !******************************************************************************************************************************* !! RMVS test particle class type, extends(whm_tp) :: rmvs_tp @@ -97,9 +90,6 @@ module rmvs_classes final :: rmvs_util_final_tp !! Finalizes the RMVS test particle object - deallocates all allocatables end type rmvs_tp - !******************************************************************************************************************************** - ! rmvs_pl class definitions and method interfaces - !******************************************************************************************************************************* !> RMVS massive body particle class type, extends(whm_pl) :: rmvs_pl @@ -124,7 +114,6 @@ module rmvs_classes interface module subroutine rmvs_discard_tp(self, system, param) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters implicit none class(rmvs_tp), intent(inout) :: self !! RMVS test particle object class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object @@ -132,7 +121,6 @@ module subroutine rmvs_discard_tp(self, system, param) end subroutine rmvs_discard_tp module function rmvs_encounter_check_tp(self, param, system, dt) result(lencounter) - use swiftest_classes, only : swiftest_parameters implicit none class(rmvs_tp), intent(inout) :: self !! RMVS test particle object class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters @@ -142,7 +130,6 @@ module function rmvs_encounter_check_tp(self, param, system, dt) result(lencount end function rmvs_encounter_check_tp module subroutine rmvs_kick_getacch_tp(self, system, param, t, lbeg) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters implicit none class(rmvs_tp), intent(inout) :: self !! RMVS test particle data structure class(swiftest_nbody_system), intent(inout) :: system !! Swiftest central body particle data structuree @@ -152,7 +139,6 @@ module subroutine rmvs_kick_getacch_tp(self, system, param, t, lbeg) end subroutine rmvs_kick_getacch_tp module subroutine rmvs_setup_pl(self, n, param) - use swiftest_classes, only : swiftest_parameters implicit none class(rmvs_pl), intent(inout) :: self !! RMVS massive body object integer(I4B), intent(in) :: n !! Number of particles to allocate space for @@ -160,14 +146,12 @@ module subroutine rmvs_setup_pl(self, n, param) end subroutine rmvs_setup_pl module subroutine rmvs_setup_initialize_system(self, param) - use swiftest_classes, only : swiftest_parameters implicit none class(rmvs_nbody_system), intent(inout) :: self !! RMVS system object class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters end subroutine rmvs_setup_initialize_system module subroutine rmvs_setup_tp(self, n, param) - use swiftest_classes, only : swiftest_parameters implicit none class(rmvs_tp), intent(inout) :: self !! RMVS test particle object integer(I4B), intent(in) :: n !! Number of particles to allocate space for @@ -175,7 +159,6 @@ module subroutine rmvs_setup_tp(self, n, param) end subroutine rmvs_setup_tp module subroutine rmvs_util_append_pl(self, source, lsource_mask) - use swiftest_classes, only : swiftest_body implicit none class(rmvs_pl), intent(inout) :: self !! RMVS massive body object class(swiftest_body), intent(in) :: source !! Source object to append @@ -183,7 +166,6 @@ module subroutine rmvs_util_append_pl(self, source, lsource_mask) end subroutine rmvs_util_append_pl module subroutine rmvs_util_append_tp(self, source, lsource_mask) - use swiftest_classes, only : swiftest_body implicit none class(rmvs_tp), intent(inout) :: self !! RMVS test particle object class(swiftest_body), intent(in) :: source !! Source object to append @@ -211,7 +193,6 @@ module subroutine rmvs_util_dealloc_tp(self) end subroutine rmvs_util_dealloc_tp module subroutine rmvs_util_fill_pl(self, inserts, lfill_list) - use swiftest_classes, only : swiftest_body implicit none class(rmvs_pl), intent(inout) :: self !! RMVS massive body object class(swiftest_body), intent(in) :: inserts !! Inserted object @@ -219,7 +200,6 @@ module subroutine rmvs_util_fill_pl(self, inserts, lfill_list) end subroutine rmvs_util_fill_pl module subroutine rmvs_util_fill_tp(self, inserts, lfill_list) - use swiftest_classes, only : swiftest_body implicit none class(rmvs_tp), intent(inout) :: self !! RMVS massive body object class(swiftest_body), intent(in) :: inserts !! Inserted object @@ -290,7 +270,6 @@ module subroutine rmvs_util_sort_rearrange_tp(self, ind) end subroutine rmvs_util_sort_rearrange_tp module subroutine rmvs_util_spill_pl(self, discards, lspill_list, ldestructive) - use swiftest_classes, only : swiftest_body implicit none class(rmvs_pl), intent(inout) :: self !! RMVS massive body object class(swiftest_body), intent(inout) :: discards !! Discarded object @@ -299,7 +278,6 @@ module subroutine rmvs_util_spill_pl(self, discards, lspill_list, ldestructive) end subroutine rmvs_util_spill_pl module subroutine rmvs_util_spill_tp(self, discards, lspill_list, ldestructive) - use swiftest_classes, only : swiftest_body implicit none class(rmvs_tp), intent(inout) :: self !! RMVS test particle object class(swiftest_body), intent(inout) :: discards !! Discarded object @@ -308,7 +286,6 @@ module subroutine rmvs_util_spill_tp(self, discards, lspill_list, ldestructive) end subroutine rmvs_util_spill_tp module subroutine rmvs_step_system(self, param, t, dt) - use swiftest_classes, only : swiftest_parameters implicit none class(rmvs_nbody_system), intent(inout) :: self !! RMVS nbody system object class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters @@ -318,4 +295,4 @@ end subroutine rmvs_step_system end interface -end module rmvs_classes +end module rmvs diff --git a/src/modules/swiftest.f90 b/src/modules/swiftest.f90 index 8ca51ffdb..3cd04545e 100644 --- a/src/modules/swiftest.f90 +++ b/src/modules/swiftest.f90 @@ -9,25 +9,1886 @@ module swiftest !! author: David A. Minton - !! graph: false !! - !! This module serves to combine all of the Swiftest project modules under a single umbrella so that they can be accessed from individual submodule implementations with a simple "use swiftest" line. - use swiftest_globals - use swiftest_operators + !! This module serves to combine all of the Swiftest project modules under a single umbrella so that they can be accessed from individual submodule implementations + !! with a simple "use swiftest" line. + !! + !! The project structure is divided into a heirarchy of modules. The lowest level of the heirarchy are the modules called in the "use" statements below. Next the + !! "swiftest" !! modules (this one), and finally each individual integrator (and potential future integrators) sit at the top. This structure is a consequence of two + !! competing constraints: + !! 1) The desire that much of the basic functionality of the code is modular, such that new functionality can be easily added without altering too much of the basic code. + !! 2) Adhering to Modern Fortran's typing rules. + !! + !! A set of "base" types is defined in the base module. These define classes of objects, (i.e. central body, massive body, and test particles) and other major types + !! used throughout the project. However, none of the derived data types are defined with concrete type-bound procedures attached (only abstract procedures). + !! However, the *interfaces* of type-bound procedures are defined using the base types as arguments. Because of the typing rules of Modern Fortran's type-bound procedure overrides, any non-pass arguments + !! (i.e. arguments not named self) must be identical in all extended types. Because some of the basic functionality in the project is split across multiple modules, + !! we cannot define type-bound procedures in base class objects until the all interfaces are defined. In order to avoid these dependency issues and not end up with a + !! massive base class with every possibly type-bound procedure interface in the project (thus reducing the modularity of the project), the type-bound procedures are added + !! to the base types here. + !! + !! Structuring this code this way adds somewhat to the verbosity of the code. The main thing that has to happen is that for any procedures where one wishes to make use of an + !! type-bound procedures defined for arguments at the swiftest-type level or higher, but that are passsed to base-level procedures, must have their arguments wrapped in + !! a select type(...); class is(...) construct in order to "reveal" the procedures. This is done throughout the project at the beginning of many procedures (along with + !! copious amounts of associate(...) statements, in order to help with code readibility) + !! + !! Adapted from David E. Kaufmann's Swifter routine: module_swifter.f90 + use globals + use operators use lambda_function - use swiftest_classes - use whm_classes - use rmvs_classes - use helio_classes - use symba_classes - use encounter_classes - use collision_classes - use fraggle_classes - use walltime_classes + use base + use encounter + use collision + use fraggle + use walltime use io_progress_bar !use advisor_annotate !$ use omp_lib implicit none public + type, extends(base_io_netcdf_parameters) :: swiftest_io_netcdf_parameters + contains + procedure :: initialize => swiftest_io_netcdf_initialize_output !! Initialize a set of parameters used to identify a NetCDF output object + procedure :: open => swiftest_io_netcdf_open !! Opens a NetCDF file and does the variable inquiries to activate variable ids + end type swiftest_io_netcdf_parameters + + + type, extends(base_storage) :: swiftest_storage + contains + procedure :: dump => swiftest_io_dump_storage !! Dumps storage object contents to file + procedure :: get_index_values => swiftest_util_get_vals_storage !! Gets the unique values of the indices of a storage object (i.e. body id or time value) + procedure :: make_index_map => swiftest_util_index_map_storage !! Maps body id values to storage index values so we don't have to use unlimited dimensions for id + procedure :: take_snapshot => swiftest_util_snapshot_system !! Takes a snapshot of the system for later file storage + final :: swiftest_util_final_storage + end type swiftest_storage + + + ! The following extended types or their children should be used, where possible, as the base of any types defined in additional modules, such as new integrators. + type, extends(base_parameters) :: swiftest_parameters + type(swiftest_storage(nframes=:)), allocatable :: system_history + contains + procedure :: dump => swiftest_io_dump_param + procedure :: reader => swiftest_io_param_reader + procedure :: writer => swiftest_io_param_writer + procedure :: read_in => swiftest_io_read_in_param + procedure :: set_display => swiftest_io_set_display_param + end type swiftest_parameters + + + !> Class definition for the kinship relationships used in bookkeeping multiple collisions bodies in a single time step. + type, extends(base_kinship) :: swiftest_kinship + integer(I4B) :: parent !! Index of parent particle + integer(I4B) :: nchild !! number of children in merger list + integer(I4B), dimension(:), allocatable :: child !! Index of children particles + contains + procedure :: dealloc => swiftest_util_dealloc_kin !! Deallocates all allocatable arrays + final :: swiftest_util_final_kin !! Finalizes the Swiftest kinship object - deallocates all allocatables + end type swiftest_kinship + + + !> An abstract class for a generic collection of Swiftest bodies + type, abstract, extends(base_object) :: swiftest_body + !! Superclass that defines the generic elements of a Swiftest particle + integer(I4B) :: nbody = 0 !! Number of bodies + logical :: lfirst = .true. !! Run the current step as a first + integer(I4B), dimension(:), allocatable :: id !! External identifier (unique) + type(swiftest_particle_info), dimension(:), allocatable :: info !! Particle metadata information + logical, dimension(:), allocatable :: lmask !! Logical mask used to select a subset of bodies when performing certain operations (drift, kick, accel, etc.) + integer(I4B), dimension(:), allocatable :: status !! An integrator-specific status indicator + logical, dimension(:), allocatable :: ldiscard !! Body should be discarded + logical, dimension(:), allocatable :: lcollision !! flag indicating whether body has merged with another this time step + logical, dimension(:), allocatable :: lencounter !! flag indicating whether body is part of an encounter this time step + real(DP), dimension(:), allocatable :: mu !! G * (Mcb + [m]) + real(DP), dimension(:,:), allocatable :: rh !! Heliocentric position + real(DP), dimension(:,:), allocatable :: vh !! Heliocentric velocity + real(DP), dimension(:,:), allocatable :: rb !! Barycentric position + real(DP), dimension(:,:), allocatable :: vb !! Barycentric velocity + real(DP), dimension(:,:), allocatable :: ah !! Total heliocentric acceleration + real(DP), dimension(:,:), allocatable :: aobl !! Barycentric accelerations of bodies due to central body oblatenes + real(DP), dimension(:,:), allocatable :: agr !! Acceleration due to post-Newtonian correction + real(DP), dimension(:,:), allocatable :: atide !! Tanngential component of acceleration of bodies due to tides + real(DP), dimension(:), allocatable :: ir3h !! Inverse heliocentric radius term (1/rh**3) + integer(I4B), dimension(:), allocatable :: isperi !! perihelion passage flag + real(DP), dimension(:), allocatable :: peri !! perihelion distance + real(DP), dimension(:), allocatable :: atp !! semimajor axis following perihelion passage + real(DP), dimension(:), allocatable :: a !! Semimajor axis (pericentric distance for a parabolic orbit) + real(DP), dimension(:), allocatable :: e !! Eccentricity + real(DP), dimension(:), allocatable :: inc !! Inclination + real(DP), dimension(:), allocatable :: capom !! Longitude of ascending node + real(DP), dimension(:), allocatable :: omega !! Argument of pericenter + real(DP), dimension(:), allocatable :: capm !! Mean anomaly + + !! Note to developers: If you add components to this class, be sure to update methods and subroutines that traverse the + !! component list, such as setup_body and util_spill + contains + procedure(abstract_discard_body), deferred :: discard + procedure(abstract_kick_body), deferred :: kick + procedure(abstract_set_mu), deferred :: set_mu + procedure(abstract_step_body), deferred :: step + procedure(abstract_accel), deferred :: accel + + ! These are concrete because the implementation is the same for all types of particles + procedure :: drift => swiftest_drift_body !! Loop through bodies and call Danby drift routine on heliocentric variables + procedure :: v2pv => swiftest_gr_vh2pv_body !! Converts from velocity to psudeovelocity for GR calculations using symplectic integrators + procedure :: pv2v => swiftest_gr_pv2vh_body !! Converts from psudeovelocity to velocity for GR calculations using symplectic integrators + procedure :: read_frame_bin => swiftest_io_read_frame_body !! I/O routine for writing out a single frame of time-series data for the central body + procedure :: read_in => swiftest_io_read_in_body !! Read in body initial conditions from an ascii file + procedure :: write_frame => swiftest_io_netcdf_write_frame_body !! I/O routine for writing out a single frame of time-series data for all bodies in the system in NetCDF format + procedure :: write_info => swiftest_io_netcdf_write_info_body !! Dump contents of particle information metadata to file + procedure :: accel_obl => swiftest_obl_acc_body !! Compute the barycentric accelerations of bodies due to the oblateness of the central body + procedure :: el2xv => swiftest_orbel_el2xv_vec !! Convert orbital elements to position and velocity vectors + procedure :: xv2el => swiftest_orbel_xv2el_vec !! Convert position and velocity vectors to orbital elements + procedure :: setup => swiftest_setup_body !! A constructor that sets the number of bodies and allocates all allocatable arrays + procedure :: accel_user => swiftest_user_kick_getacch_body !! Add user-supplied heliocentric accelerations to planets + procedure :: append => swiftest_util_append_body !! Appends elements from one structure to another + procedure :: dealloc => swiftest_util_dealloc_body !! Deallocates all allocatable arrays + procedure :: fill => swiftest_util_fill_body !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) + procedure :: get_peri => swiftest_util_peri_body !! Determine system pericenter passages for test particles + procedure :: resize => swiftest_util_resize_body !! Checks the current size of a Swiftest body against the requested size and resizes it if it is too small. + + procedure :: set_ir3 => swiftest_util_set_ir3h !! Sets the inverse heliocentric radius term (1/rh**3) + procedure :: sort => swiftest_util_sort_body !! Sorts body arrays by a sortable componen + procedure :: rearrange => swiftest_util_sort_rearrange_body !! Rearranges the order of array elements of body based on an input index array. Used in sorting methods + procedure :: spill => swiftest_util_spill_body !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) + generic :: read_frame => read_frame_bin !! Add the generic read frame for Fortran binary files + end type swiftest_body + + + type, extends(base_particle_info) :: swiftest_particle_info + character(len=NAMELEN) :: name !! Non-unique name + character(len=NAMELEN) :: particle_type !! String containing a description of the particle type (e.g. Central Body, Massive Body, Test Particle) + character(len=NAMELEN) :: origin_type !! String containing a description of the origin of the particle (e.g. Initial Conditions, Supercatastrophic, Disruption, etc.) + real(DP) :: origin_time !! The time of the particle's formation + integer(I4B) :: collision_id !! The ID of the collision that formed the particle + real(DP), dimension(NDIM) :: origin_rh !! The heliocentric distance vector at the time of the particle's formation + real(DP), dimension(NDIM) :: origin_vh !! The heliocentric velocity vector at the time of the particle's formation + real(DP) :: discard_time !! The time of the particle's discard + character(len=NAMELEN) :: status !! Particle status description: Active, Merged, Fragmented, etc. + real(DP), dimension(NDIM) :: discard_rh !! The heliocentric distance vector at the time of the particle's discard + real(DP), dimension(NDIM) :: discard_vh !! The heliocentric velocity vector at the time of the particle's discard + integer(I4B) :: discard_body_id !! The id of the other body involved in the discard (0 if no other body involved) + contains + procedure :: copy => swiftest_util_copy_particle_info !! Copies one set of information object components into another, component-by-component + procedure :: set_value => swiftest_util_set_particle_info !! Sets one or more values of the particle information metadata object + end type swiftest_particle_info + + + type, abstract, extends(base_object) :: swiftest_cb + !> An abstract class for a generic central body in a Swiftest simulation + class(swiftest_particle_info), allocatable :: info !! Particle metadata information + integer(I4B) :: id = 0 !! External identifier (unique) + real(DP) :: mass = 0.0_DP !! Central body mass (units MU) + real(DP) :: Gmass = 0.0_DP !! Central mass gravitational term G * mass (units GU * MU) + real(DP) :: radius = 0.0_DP !! Central body radius (units DU) + real(DP) :: density = 1.0_DP !! Central body mass density - calculated internally (units MU / DU**3) + real(DP) :: j2rp2 = 0.0_DP !! J2*R^2 term for central body + real(DP) :: j4rp4 = 0.0_DP !! J4*R^2 term for central body + real(DP), dimension(NDIM) :: aobl = 0.0_DP !! Barycentric acceleration due to central body oblatenes + real(DP), dimension(NDIM) :: atide = 0.0_DP !! Barycentric acceleration due to central body oblatenes + real(DP), dimension(NDIM) :: aoblbeg = 0.0_DP !! Barycentric acceleration due to central body oblatenes at beginning of step + real(DP), dimension(NDIM) :: aoblend = 0.0_DP !! Barycentric acceleration due to central body oblatenes at end of step + real(DP), dimension(NDIM) :: atidebeg = 0.0_DP !! Barycentric acceleration due to central body oblatenes at beginning of step + real(DP), dimension(NDIM) :: atideend = 0.0_DP !! Barycentric acceleration due to central body oblatenes at end of step + real(DP), dimension(NDIM) :: rb = 0.0_DP !! Barycentric position (units DU) + real(DP), dimension(NDIM) :: vb = 0.0_DP !! Barycentric velocity (units DU / TU) + real(DP), dimension(NDIM) :: agr = 0.0_DP !! Acceleration due to post-Newtonian correction + real(DP), dimension(NDIM) :: Ip = 0.0_DP !! Unitless principal moments of inertia (I1, I2, I3) / (MR**2). Principal axis rotation assumed. + real(DP), dimension(NDIM) :: rot = 0.0_DP !! Body rotation vector in inertial coordinate frame (units rad / TU) + real(DP) :: k2 = 0.0_DP !! Tidal Love number + real(DP) :: Q = 0.0_DP !! Tidal quality factor + real(DP) :: tlag = 0.0_DP !! Tidal phase lag angle + real(DP), dimension(NDIM) :: L0 = 0.0_DP !! Initial angular momentum of the central body + real(DP), dimension(NDIM) :: dL = 0.0_DP !! Change in angular momentum of the central body + real(DP) :: GM0 = 0.0_DP !! Initial G*mass of the central body + real(DP) :: dGM = 0.0_DP !! Change in G*mass of the central body + real(DP) :: R0 = 0.0_DP !! Initial radius of the central body + real(DP) :: dR = 0.0_DP !! Change in the radius of the central body + contains + procedure :: read_in => swiftest_io_read_in_cb !! Read in central body initial conditions from an ASCII file + end type swiftest_cb + + + type, abstract, extends(swiftest_body) :: swiftest_pl + !! Superclass that defines the generic elements of a Swiftest particle + real(DP), dimension(:), allocatable :: mass !! Body mass (units MU) + real(DP), dimension(:), allocatable :: Gmass !! Mass gravitational term G * mass (units GU * MU) + real(DP), dimension(:), allocatable :: rhill !! Body mass (units MU) + real(DP), dimension(:), allocatable :: renc !! Critical radius for close encounters + real(DP), dimension(:), allocatable :: radius !! Body radius (units DU) + real(DP), dimension(:), allocatable :: density !! Body mass density - calculated internally (units MU / DU**3) + real(DP), dimension(:,:), allocatable :: rbeg !! Position at beginning of step + real(DP), dimension(:,:), allocatable :: rend !! Position at end of step + real(DP), dimension(:,:), allocatable :: vbeg !! Velocity at beginning of step + real(DP), dimension(:,:), allocatable :: Ip !! Unitless principal moments of inertia (I1, I2, I3) / (MR**2). Principal axis rotation assumed. + real(DP), dimension(:,:), allocatable :: rot !! Body rotation vector in inertial coordinate frame (units rad / TU) + real(DP), dimension(:), allocatable :: k2 !! Tidal Love number + real(DP), dimension(:), allocatable :: Q !! Tidal quality factor + real(DP), dimension(:), allocatable :: tlag !! Tidal phase lag + integer(I4B), dimension(:,:), allocatable :: k_plpl !! Index array used to convert flattened the body-body comparison upper triangular matrix + integer(I8B) :: nplpl !! Number of body-body comparisons in the flattened upper triangular matrix + type(swiftest_kinship), dimension(:), allocatable :: kin !! Array of merger relationship structures that can account for multiple pairwise mergers in a single step + logical, dimension(:), allocatable :: lmtiny !! flag indicating whether this body is below the GMTINY cutoff value + integer(I4B) :: nplm !! number of bodies above the GMTINY limit + integer(I8B) :: nplplm !! Number of body (all massive)-body (only those above GMTINY) comparisons in the flattened upper triangular matrix + integer(I4B), dimension(:), allocatable :: nplenc !! number of encounters with other planets this time step + integer(I4B), dimension(:), allocatable :: ntpenc !! number of encounters with test particles this time step + !! Note to developers: If you add components to this class, be sure to update methods and subroutines that traverse the + !! component list, such as setup_pl and util_spill_pl + contains + ! Massive body-specific concrete methods + ! These are concrete because they are the same implemenation for all integrators + procedure :: make_impactors => make_impactors_pl !! Make impactors out of the current kinship relationships + procedure :: discard => swiftest_discard_pl !! Placeholder method for discarding massive bodies + procedure :: accel_int => swiftest_kick_getacch_int_pl !! Compute direct cross (third) term heliocentric accelerations of massive bodies + procedure :: accel_obl => swiftest_obl_acc_pl !! Compute the barycentric accelerations of bodies due to the oblateness of the central body + procedure :: setup => swiftest_setup_pl !! A base constructor that sets the number of bodies and allocates and initializes all arrays + ! procedure :: accel_tides => tides_kick_getacch_pl !! Compute the accelerations of bodies due to tidal interactions with the central body + procedure :: append => swiftest_util_append_pl !! Appends elements from one structure to another + procedure :: h2b => swiftest_util_coord_h2b_pl !! Convert massive bodies from heliocentric to barycentric coordinates (position and velocity) + procedure :: b2h => swiftest_util_coord_b2h_pl !! Convert massive bodies from barycentric to heliocentric coordinates (position and velocity) + procedure :: vh2vb => swiftest_util_coord_vh2vb_pl !! Convert massive bodies from heliocentric to barycentric coordinates (velocity only) + procedure :: vb2vh => swiftest_util_coord_vb2vh_pl !! Convert massive bodies from barycentric to heliocentric coordinates (velocity only) + procedure :: rh2rb => swiftest_util_coord_rh2rb_pl !! Convert massive bodies from heliocentric to barycentric coordinates (position only) + procedure :: dealloc => swiftest_util_dealloc_pl !! Deallocates all allocatable arrays + procedure :: fill => swiftest_util_fill_pl !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) + procedure :: flatten => swiftest_util_flatten_eucl_plpl !! Sets up the (i, j) -> k indexing used for the single-loop blocking Euclidean distance matrix + procedure :: rearray => swiftest_util_rearray_pl !! Clean up the massive body structures to remove discarded bodies and add new bodies + procedure :: resize => swiftest_util_resize_pl !! Checks the current size of a Swiftest body against the requested size and resizes it if it is too small. + procedure :: reset_kinship => swiftest_util_reset_kinship_pl !! Resets the kinship status of bodies + procedure :: set_beg_end => swiftest_util_set_beg_end_pl !! Sets the beginning and ending positions and velocities of planets. + procedure :: set_mu => swiftest_util_set_mu_pl !! Method used to construct the vectorized form of the central body mass + procedure :: set_rhill => swiftest_util_set_rhill !! Calculates the Hill's radii for each body + procedure :: set_renc_I4B => swiftest_util_set_renc_I4B !! Sets the critical radius for encounter given an inpput integer scale factor + procedure :: set_renc_DP => swiftest_util_set_renc_DP !! Sets the critical radius for encounter given an input real scale factor + procedure :: sort => swiftest_util_sort_pl !! Sorts body arrays by a sortable component + procedure :: rearrange => swiftest_util_sort_rearrange_pl !! Rearranges the order of array elements of body based on an input index array. Used in sorting methods + procedure :: spill => swiftest_util_spill_pl !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) + generic :: set_renc => set_renc_I4B, set_renc_DP + end type swiftest_pl + + + type, abstract, extends(swiftest_body) :: swiftest_tp + !! Superclass that defines the generic elements of a Swiftest test particle + integer(I4B), dimension(:,:), allocatable :: k_pltp !! Index array used to convert flattened the body-body comparison upper triangular matrix + integer(I8B) :: npltp !! Number of pl-tp comparisons in the flattened upper triangular matrix + integer(I4B), dimension(:), allocatable :: nplenc !! number of encounters with planets this time step + !! Note to developers: If you add components to this class, be sure to update methods and subroutines that traverse the + !! component list, such as setup_tp and util_spill_tp + contains + ! Test particle-specific concrete methods + ! These are concrete because they are the same implemenation for all integrators + procedure :: discard => swiftest_discard_tp !! Check to see if test particles should be discarded based on their positions relative to the massive bodies + procedure :: accel_int => swiftest_kick_getacch_int_tp !! Compute direct cross (third) term heliocentric accelerations of test particles by massive bodies + procedure :: accel_obl => swiftest_obl_acc_tp !! Compute the barycentric accelerations of bodies due to the oblateness of the central body + procedure :: setup => swiftest_setup_tp !! A base constructor that sets the number of bodies and + procedure :: append => swiftest_util_append_tp !! Appends elements from one structure to another + procedure :: h2b => swiftest_util_coord_h2b_tp !! Convert test particles from heliocentric to barycentric coordinates (position and velocity) + procedure :: b2h => swiftest_util_coord_b2h_tp !! Convert test particles from barycentric to heliocentric coordinates (position and velocity) + procedure :: vb2vh => swiftest_util_coord_vb2vh_tp !! Convert test particles from barycentric to heliocentric coordinates (velocity only) + procedure :: vh2vb => swiftest_util_coord_vh2vb_tp !! Convert test particles from heliocentric to barycentric coordinates (velocity only) + procedure :: rh2rb => swiftest_util_coord_rh2rb_tp !! Convert test particles from heliocentric to barycentric coordinates (position only) + procedure :: dealloc => swiftest_util_dealloc_tp !! Deallocates all allocatable arrays + procedure :: fill => swiftest_util_fill_tp !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) + procedure :: resize => swiftest_util_resize_tp !! Checks the current size of a Swiftest body against the requested size and resizes it if it is too small. + procedure :: set_mu => swiftest_util_set_mu_tp !! Method used to construct the vectorized form of the central body mass + procedure :: sort => swiftest_util_sort_tp !! Sorts body arrays by a sortable component + procedure :: rearrange => swiftest_util_sort_rearrange_tp !! Rearranges the order of array elements of body based on an input index array. Used in sorting methods + procedure :: spill => swiftest_util_spill_tp !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) + end type swiftest_tp + + + !> An abstract class for a basic Swiftest nbody system + type, abstract, extends(base_nbody_system) :: swiftest_nbody_system + !! This superclass contains a minimial system of a set of test particles (tp), massive bodies (pl), and a central body (cb) + !! The full swiftest_nbody_system type that is used as the parent class of all integrators is defined in collision + + class(swiftest_cb), allocatable :: cb !! Central body data structure + class(swiftest_pl), allocatable :: pl !! Massive body data structure + class(swiftest_tp), allocatable :: tp !! Test particle data structure + + class(swiftest_tp), allocatable :: tp_discards !! Discarded test particle data structure + class(swiftest_pl), allocatable :: pl_discards !! Discarded massive body particle data structure + class(swiftest_pl), allocatable :: pl_adds !! List of added bodies in mergers or collisions + class(swiftest_tp), allocatable :: tp_adds !! List of added bodies in mergers or collisions + class(collision_list_pltp), allocatable :: pltp_encounter !! List of massive body-test particle encounters in a single step + class(collision_list_plpl), allocatable :: plpl_encounter !! List of massive body-massive body encounters in a single step + class(collision_list_plpl), allocatable :: plpl_collision !! List of massive body-massive body collisions in a single step + class(collision_list_plpl), allocatable :: pltp_collision !! List of massive body-massive body collisions in a single step + class(collision_system), allocatable :: collision_system !! Collision system object + class(encounter_storage(nframes=:)), allocatable :: encounter_history !! Stores encounter history for later retrieval and saving to file + class(collision_storage(nframes=:)), allocatable :: collision_history !! Stores encounter history for later retrieval and saving to file + + real(DP) :: t = -1.0_DP !! Integration current time + real(DP) :: GMtot = 0.0_DP !! Total system mass - used for barycentric coordinate conversion + real(DP) :: ke_orbit = 0.0_DP !! System orbital kinetic energy + real(DP) :: ke_spin = 0.0_DP !! System spin kinetic energy + real(DP) :: pe = 0.0_DP !! System potential energy + real(DP) :: te = 0.0_DP !! System total energy + real(DP) :: oblpot = 0.0_DP !! System potential energy due to oblateness of the central body + real(DP), dimension(NDIM) :: Lorbit = 0.0_DP !! System orbital angular momentum vector + real(DP), dimension(NDIM) :: Lspin = 0.0_DP !! System spin angular momentum vector + real(DP), dimension(NDIM) :: Ltot = 0.0_DP !! System angular momentum vector + real(DP) :: ke_orbit_orig = 0.0_DP !! Initial orbital kinetic energy + real(DP) :: ke_spin_orig = 0.0_DP !! Initial spin kinetic energy + real(DP) :: pe_orig = 0.0_DP !! Initial potential energy + real(DP) :: Eorbit_orig = 0.0_DP !! Initial orbital energy + real(DP) :: GMtot_orig = 0.0_DP !! Initial system mass + real(DP), dimension(NDIM) :: Ltot_orig = 0.0_DP !! Initial total angular momentum vector + real(DP), dimension(NDIM) :: Lorbit_orig = 0.0_DP !! Initial orbital angular momentum + real(DP), dimension(NDIM) :: Lspin_orig = 0.0_DP !! Initial spin angular momentum vector + real(DP), dimension(NDIM) :: Lescape = 0.0_DP !! Angular momentum of bodies that escaped the system (used for bookeeping) + real(DP) :: GMescape = 0.0_DP !! Mass of bodies that escaped the system (used for bookeeping) + real(DP) :: Ecollisions = 0.0_DP !! Energy lost from system due to collisions + real(DP) :: Euntracked = 0.0_DP !! Energy gained from system due to escaped bodies + + ! Energy, momentum, and mass errors (used in error reporting) + real(DP) :: ke_orbit_error = 0.0_DP + real(DP) :: ke_spin_error = 0.0_DP + real(DP) :: pe_error = 0.0_DP + real(DP) :: Eorbit_error = 0.0_DP + real(DP) :: Ecoll_error = 0.0_DP + real(DP) :: Euntracked_error = 0.0_DP + real(DP) :: Etot_error = 0.0_DP + real(DP) :: Lorbit_error = 0.0_DP + real(DP) :: Lspin_error = 0.0_DP + real(DP) :: Lescape_error = 0.0_DP + real(DP) :: Ltot_error = 0.0_DP + real(DP) :: Mtot_error = 0.0_DP + real(DP) :: Mescape_error = 0.0_DP + + logical :: lbeg !! True if this is the beginning of a step. This is used so that test particle steps can be calculated + !! separately from massive bodies. Massive body variables are saved at half steps, and passed to + !! the test particles + contains + !> Each integrator will have its own version of the step + procedure(abstract_step_system), deferred :: step + + ! Concrete classes that are common to the basic integrator (only test particles considered for discard) + procedure :: discard => swiftest_discard_system !! Perform a discard step on the system + procedure :: compact_output => swiftest_io_compact_output !! Prints out out terminal output when display_style is set to COMPACT + procedure :: conservation_report => swiftest_io_conservation_report !! Compute energy and momentum and print out the change with time + procedure :: dump => swiftest_io_dump_system !! Dump the state of the system to a file + procedure :: get_old_t_final => swiftest_io_netcdf_get_old_t_final_system !! Validates the dump file to check whether the dump file initial conditions duplicate the last frame of the netcdf output. + procedure :: read_frame => swiftest_io_netcdf_read_frame_system !! Read in a frame of input data from file + procedure :: write_frame_netcdf => swiftest_io_netcdf_write_frame_system !! Write a frame of input data from file + procedure :: write_frame_system => swiftest_io_write_frame_system !! Write a frame of input data from file + procedure :: read_hdr => swiftest_io_netcdf_read_hdr_system !! Read a header for an output frame in NetCDF format + procedure :: write_hdr => swiftest_io_netcdf_write_hdr_system !! Write a header for an output frame in NetCDF format + procedure :: read_in => swiftest_io_read_in_system !! Reads the initial conditions for an nbody system + procedure :: read_particle_info => swiftest_io_netcdf_read_particle_info_system !! Read in particle metadata from file + procedure :: obl_pot => swiftest_obl_pot_system !! Compute the contribution to the total gravitational potential due solely to the oblateness of the central body + procedure :: initialize => swiftest_setup_initialize_system !! Initialize the system from input files + procedure :: init_particle_info => swiftest_setup_initialize_particle_info_system !! Initialize the system from input files + ! procedure :: step_spin => tides_step_spin_system !! Steps the spins of the massive & central bodies due to tides. + procedure :: set_msys => swiftest_util_set_msys !! Sets the value of msys from the masses of system bodies. + procedure :: get_energy_and_momentum => swiftest_util_get_energy_momentum_system !! Calculates the total system energy and momentum + procedure :: get_idvals => swiftest_util_get_idvalues_system !! Returns an array of all id values in use in the system + procedure :: rescale => swiftest_util_rescale_system !! Rescales the system into a new set of units + procedure :: validate_ids => swiftest_util_valid_id_system !! Validate the numerical ids passed to the system and save the maximum value + procedure :: write_discard => swiftest_io_write_discard !! Write out information about discarded and merged planets and test particles in SyMBA + generic :: write_frame => write_frame_system, write_frame_netcdf !! Generic method call for reading a frame of output data + end type swiftest_nbody_system + + + abstract interface + + subroutine abstract_accel(self, system, param, t, lbeg) + import swiftest_body, swiftest_nbody_system, swiftest_parameters, DP + class(swiftest_body), intent(inout) :: self !! Swiftest body data structure + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + real(DP), intent(in) :: t !! Current simulation time + logical, intent(in) :: lbeg !! Optional argument that determines whether or not this is the beginning or end of the step + end subroutine abstract_accel + + subroutine abstract_discard_body(self, system, param) + import swiftest_body, swiftest_nbody_system, swiftest_parameters + class(swiftest_body), intent(inout) :: self !! Swiftest body object + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine abstract_discard_body + + subroutine abstract_kick_body(self, system, param, t, dt, lbeg) + import swiftest_body, swiftest_nbody_system, swiftest_parameters, DP + implicit none + class(swiftest_body), intent(inout) :: self !! Swiftest generic body object + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system objec + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + real(DP), intent(in) :: t !! Current time + real(DP), intent(in) :: dt !! Stepsize + logical, intent(in) :: lbeg !! Logical flag indicating whether this is the beginning of the half step or not. + end subroutine abstract_kick_body + + subroutine abstract_set_mu(self, cb) + import swiftest_body, swiftest_cb + class(swiftest_body), intent(inout) :: self !! Swiftest body object + class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object + end subroutine abstract_set_mu + + subroutine abstract_step_body(self, system, param, t, dt) + import DP, swiftest_body, swiftest_nbody_system, swiftest_parameters + implicit none + class(swiftest_body), intent(inout) :: self !! Swiftest body object + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest system object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + real(DP), intent(in) :: t !! Simulation time + real(DP), intent(in) :: dt !! Current stepsize + end subroutine abstract_step_body + + subroutine abstract_step_system(self, param, t, dt) + import DP, swiftest_nbody_system, swiftest_parameters + implicit none + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest system object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + real(DP), intent(in) :: t !! Simulation time + real(DP), intent(in) :: dt !! Current stepsize + end subroutine abstract_step_system + end interface + + + interface + module subroutine swiftest_discard_pl(self, system, param) + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameter + end subroutine swiftest_discard_pl + + module subroutine swiftest_discard_system(self, param) + implicit none + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest system object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine swiftest_discard_system + + module subroutine swiftest_discard_tp(self, system, param) + implicit none + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine swiftest_discard_tp + + module subroutine swiftest_drift_all(mu, x, v, n, param, dt, lmask, iflag) + implicit none + real(DP), dimension(:), intent(in) :: mu !! Vector of gravitational constants + real(DP), dimension(:,:), intent(inout) :: x, v !! Position and velocity vectors + integer(I4B), intent(in) :: n !! number of bodies + class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters + real(DP), intent(in) :: dt !! Stepsize + logical, dimension(:), intent(in) :: lmask !! Logical mask of size self%nbody that determines which bodies to drift. + integer(I4B), dimension(:), intent(out) :: iflag !! Vector of error flags. 0 means no problem + end subroutine swiftest_drift_all + + module subroutine swiftest_drift_body(self, system, param, dt) + implicit none + class(swiftest_body), intent(inout) :: self !! Swiftest particle data structure + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters + real(DP), intent(in) :: dt !! Stepsize + end subroutine swiftest_drift_body + + pure elemental module subroutine swiftest_drift_one(mu, px, py, pz, vx, vy, vz, dt, iflag) + !$omp declare simd(swiftest_drift_one) + implicit none + real(DP), intent(in) :: mu !! G * (Mcb + m), G = gravitational constant, Mcb = mass of central body, m = mass of body to drift + real(DP), intent(inout) :: px, py, pz, vx, vy, vz !! Position and velocity of body to drift + real(DP), intent(in) :: dt !! Step size + integer(I4B), intent(out) :: iflag !! iflag : error status flag for Danby drift (0 = OK, nonzero = ERROR) + end subroutine swiftest_drift_one + + pure module subroutine swiftest_gr_kick_getaccb_ns_body(self, system, param) + implicit none + class(swiftest_body), intent(inout) :: self !! Swiftest generic body object + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters + end subroutine swiftest_gr_kick_getaccb_ns_body + + pure module subroutine swiftest_gr_kick_getacch(mu, x, lmask, n, inv_c2, agr) + implicit none + real(DP), dimension(:), intent(in) :: mu !! Gravitational constant + real(DP), dimension(:,:), intent(in) :: x !! Position vectors + logical, dimension(:), intent(in) :: lmask !! Logical mask indicating which bodies to compute + integer(I4B), intent(in) :: n !! Total number of bodies + real(DP), intent(in) :: inv_c2 !! Inverse speed of light squared: 1 / c**2 + real(DP), dimension(:,:), intent(out) :: agr !! Accelerations + end subroutine swiftest_gr_kick_getacch + + pure module subroutine swiftest_gr_p4_pos_kick(param, x, v, dt) + implicit none + class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters + real(DP), dimension(:), intent(inout) :: x !! Position vector + real(DP), dimension(:), intent(in) :: v !! Velocity vector + real(DP), intent(in) :: dt !! Step size + end subroutine swiftest_gr_p4_pos_kick + + pure module subroutine swiftest_gr_pseudovel2vel(param, mu, rh, pv, vh) + implicit none + class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters + real(DP), intent(in) :: mu !! G * (Mcb + m), G = gravitational constant, Mcb = mass of central body, m = mass of body + real(DP), dimension(:), intent(in) :: rh !! Swiftestcentric position vector + real(DP), dimension(:), intent(in) :: pv !! Pseudovelocity velocity vector - see Saha & Tremain (1994), eq. (32) + real(DP), dimension(:), intent(out) :: vh !! Swiftestcentric velocity vector + end subroutine swiftest_gr_pseudovel2vel + + pure module subroutine swiftest_gr_pv2vh_body(self, param) + implicit none + class(swiftest_body), intent(inout) :: self !! Swiftest particle object + class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters + end subroutine swiftest_gr_pv2vh_body + + pure module subroutine swiftest_gr_vel2pseudovel(param, mu, rh, vh, pv) + implicit none + class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters + real(DP), intent(in) :: mu !! G * (Mcb + m), G = gravitational constant, Mcb = mass of central body, m = mass of body + real(DP), dimension(:), intent(in) :: rh !! Swiftestcentric position vector + real(DP), dimension(:), intent(in) :: vh !! Swiftestcentric velocity vector + real(DP), dimension(:), intent(out) :: pv !! Pseudovelocity vector - see Saha & Tremain (1994), eq. (32) + end subroutine swiftest_gr_vel2pseudovel + + pure module subroutine swiftest_gr_vh2pv_body(self, param) + implicit none + class(swiftest_body), intent(inout) :: self !! Swiftest particle object + class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters + end subroutine swiftest_gr_vh2pv_body + + module subroutine swiftest_io_compact_output(self, param, timer) + implicit none + class(swiftest_nbody_system), intent(in) :: self !! Swiftest nbody system object + class(swiftest_parameters), intent(in) :: param !! Input colleciton of user-defined parameters + class(*), intent(in) :: timer !! Object used for computing elapsed wall time + end subroutine swiftest_io_compact_output + + module subroutine swiftest_io_conservation_report(self, param, lterminal) + implicit none + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object + class(swiftest_parameters), intent(inout) :: param !! Input colleciton of user-defined parameters + logical, intent(in) :: lterminal !! Indicates whether to output information to the terminal screen + end subroutine swiftest_io_conservation_report + + module subroutine swiftest_io_dump_param(self, param_file_name) + implicit none + class(swiftest_parameters),intent(in) :: self !! Output collection of parameters + character(len=*), intent(in) :: param_file_name !! Parameter input file name (i.e. param.in) + end subroutine swiftest_io_dump_param + + module subroutine swiftest_io_dump_system(self, param) + implicit none + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest system object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine swiftest_io_dump_system + + module subroutine swiftest_io_dump_storage(self, param) + implicit none + class(swiftest_storage(*)), intent(inout) :: self !! Swiftest simulation history storage object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine swiftest_io_dump_storage + + module subroutine swiftest_io_get_args(integrator, param_file_name, display_style) + implicit none + character(len=:), allocatable, intent(inout) :: integrator !! Symbolic code of the requested integrator + character(len=:), allocatable, intent(inout) :: param_file_name !! Name of the input parameters file + character(len=:), allocatable, intent(inout) :: display_style !! Style of the output display {"STANDARD", "COMPACT"}). Default is "STANDARD" + end subroutine swiftest_io_get_args + + module function swiftest_io_get_token(buffer, ifirst, ilast, ierr) result(token) + implicit none + character(len=*), intent(in) :: buffer !! Input string buffer + integer(I4B), intent(inout) :: ifirst !! Index of the buffer at which to start the search for a token + integer(I4B), intent(out) :: ilast !! Index of the buffer at the end of the returned token + integer(I4B), intent(out) :: ierr !! Error code + character(len=:), allocatable :: token !! Returned token string + end function swiftest_io_get_token + + module subroutine swiftest_io_log_one_message(file, message) + implicit none + character(len=*), intent(in) :: file !! Name of file to log + character(len=*), intent(in) :: message + end subroutine swiftest_io_log_one_message + + module subroutine swiftest_io_log_start(param, file, header) + implicit none + class(swiftest_parameters), intent(in) :: param !! Current Swiftest run configuration parameters + character(len=*), intent(in) :: file !! Name of file to log + character(len=*), intent(in) :: header !! Header to print at top of log file + end subroutine swiftest_io_log_start + + module subroutine swiftest_io_param_reader(self, unit, iotype, v_list, iostat, iomsg) + implicit none + class(swiftest_parameters), intent(inout) :: self !! Collection of parameters + integer(I4B), intent(in) :: unit !! File unit number + character(len=*), intent(in) :: iotype !! Dummy argument passed to the input/output procedure contains the text from the char-literal-constant, prefixed with DT. + !! If you do not include a char-literal-constant, the iotype argument contains only DT. + character(len=*), intent(in) :: v_list(:) !! The first element passes the integrator code to the reader + integer(I4B), intent(out) :: iostat !! IO status code + character(len=*), intent(inout) :: iomsg !! Message to pass if iostat /= 0 + end subroutine swiftest_io_param_reader + + module subroutine swiftest_io_param_writer(self, unit, iotype, v_list, iostat, iomsg) + implicit none + class(swiftest_parameters), intent(in) :: self !! Collection of parameters + integer(I4B), intent(in) :: unit !! File unit number + character(len=*), intent(in) :: iotype !! Dummy argument passed to the input/output procedure contains the text from the char-literal-constant, prefixed with DT. + !! If you do not include a char-literal-constant, the iotype argument contains only DT. + integer(I4B), intent(in) :: v_list(:) !! Not used in this procedure + integer(I4B), intent(out) :: iostat !! IO status code + character(len=*), intent(inout) :: iomsg !! Message to pass if iostat /= 0 + end subroutine swiftest_io_param_writer + end interface + + interface io_param_writer_one + module subroutine swiftest_io_param_writer_one_char(param_name, param_value, unit) + implicit none + character(len=*), intent(in) :: param_name !! Name of parameter to print + character(len=*), intent(in) :: param_value !! Value of parameter to print + integer(I4B), intent(in) :: unit !! Open file unit number to print parameter to + end subroutine swiftest_io_param_writer_one_char + + module subroutine swiftest_io_param_writer_one_DP(param_name, param_value, unit) + implicit none + character(len=*), intent(in) :: param_name !! Name of parameter to print + real(DP), intent(in) :: param_value !! Value of parameter to print + integer(I4B), intent(in) :: unit !! Open file unit number to print parameter to + end subroutine swiftest_io_param_writer_one_DP + + module subroutine swiftest_io_param_writer_one_DParr(param_name, param_value, unit) + implicit none + character(len=*), intent(in) :: param_name !! Name of parameter to print + real(DP), dimension(:), intent(in) :: param_value !! Value of parameter to print + integer(I4B), intent(in) :: unit !! Open file unit number to print parameter to + end subroutine swiftest_io_param_writer_one_DParr + + module subroutine swiftest_io_param_writer_one_I4B(param_name, param_value, unit) + implicit none + character(len=*), intent(in) :: param_name !! Name of parameter to print + integer(I4B), intent(in) :: param_value !! Value of parameter to print + integer(I4B), intent(in) :: unit !! Open file unit number to print parameter to + end subroutine swiftest_io_param_writer_one_I4B + + module subroutine swiftest_io_param_writer_one_I4Barr(param_name, param_value, unit) + implicit none + character(len=*), intent(in) :: param_name !! Name of parameter to print + integer(I4B), dimension(:), intent(in) :: param_value !! Value of parameter to print + integer(I4B), intent(in) :: unit !! Open file unit number to print parameter to + end subroutine swiftest_io_param_writer_one_I4Barr + + module subroutine swiftest_io_param_writer_one_I8B(param_name, param_value, unit) + implicit none + character(len=*), intent(in) :: param_name !! Name of parameter to print + integer(I8B), intent(in) :: param_value !! Value of parameter to print + integer(I4B), intent(in) :: unit !! Open file unit number to print parameter to + end subroutine swiftest_io_param_writer_one_I8B + + module subroutine swiftest_io_param_writer_one_logical(param_name, param_value, unit) + implicit none + character(len=*), intent(in) :: param_name !! Name of parameter to print + logical, intent(in) :: param_value !! Value of parameter to print + integer(I4B), intent(in) :: unit !! Open file unit number to print parameter to + end subroutine swiftest_io_param_writer_one_logical + + module subroutine swiftest_io_param_writer_one_QP(param_name, param_value, unit) + implicit none + character(len=*), intent(in) :: param_name !! Name of parameter to print + real(QP), intent(in) :: param_value !! Value of parameter to print + integer(I4B), intent(in) :: unit !! Open file unit number to print parameter to + end subroutine swiftest_io_param_writer_one_QP + end interface io_param_writer_one + + interface + + module subroutine swiftest_io_read_in_body(self,param) + implicit none + class(swiftest_body), intent(inout) :: self !! Swiftest base object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine swiftest_io_read_in_body + + module subroutine swiftest_io_read_in_cb(self,param) + implicit none + class(swiftest_cb), intent(inout) :: self !! Swiftest base object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine swiftest_io_read_in_cb + + module subroutine swiftest_io_read_in_param(self, param_file_name) + implicit none + class(swiftest_parameters), intent(inout) :: self !! Current run configuration parameters + character(len=*), intent(in) :: param_file_name !! Parameter input file name (i.e. param.in) + end subroutine swiftest_io_read_in_param + + module subroutine swiftest_io_read_in_system(self, param) + implicit none + class(swiftest_nbody_system), intent(inout) :: self + class(swiftest_parameters), intent(inout) :: param + end subroutine swiftest_io_read_in_system + + module function swiftest_io_read_frame_body(self, iu, param) result(ierr) + implicit none + class(swiftest_body), intent(inout) :: self !! Swiftest body object + integer(I4B), intent(inout) :: iu !! Unit number for the output file to write frame to + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + integer(I4B) :: ierr !! Error code: returns 0 if the read is successful + end function swiftest_io_read_frame_body + + module function swiftest_io_read_frame_system(self, iu, param) result(ierr) + implicit none + class(swiftest_nbody_system),intent(inout) :: self !! Swiftest system object + integer(I4B), intent(inout) :: iu !! Unit number for the output file to read frame from + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + integer(I4B) :: ierr !! Error code: returns 0 if the read is successful + end function swiftest_io_read_frame_system + + module subroutine swiftest_io_set_display_param(self, display_style) + implicit none + class(swiftest_parameters), intent(inout) :: self !! Current run configuration parameters + character(*), intent(in) :: display_style !! Style of the output display + end subroutine swiftest_io_set_display_param + + module subroutine swiftest_io_toupper(string) + implicit none + character(*), intent(inout) :: string !! String to make upper case + end subroutine swiftest_io_toupper + + module subroutine swiftest_io_write_frame_system(self, param) + implicit none + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest system object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine swiftest_io_write_frame_system + + module subroutine swiftest_kick_getacch_int_pl(self, param) + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_parameters), intent(inout) :: param !! Current swiftest run configuration parameters + end subroutine swiftest_kick_getacch_int_pl + + module subroutine swiftest_kick_getacch_int_tp(self, param, GMpl, rhp, npl) + implicit none + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + class(swiftest_parameters), intent(inout) :: param !! Current swiftest run configuration parameters + real(DP), dimension(:), intent(in) :: GMpl !! Massive body masses + real(DP), dimension(:,:), intent(in) :: rhp !! Massive body position vectors + integer(I4B), intent(in) :: npl !! Number of active massive bodies + end subroutine swiftest_kick_getacch_int_tp + + module subroutine swiftest_kick_getacch_int_all_flat_pl(npl, nplpl, k_plpl, x, Gmass, radius, acc) + implicit none + integer(I4B), intent(in) :: npl !! Number of massive bodies + integer(I8B), intent(in) :: nplpl !! Number of massive body interactions to compute + integer(I4B), dimension(:,:), intent(in) :: k_plpl !! Array of interaction pair indices (flattened upper triangular matrix) + real(DP), dimension(:,:), intent(in) :: x !! Position vector array + real(DP), dimension(:), intent(in) :: Gmass !! Array of massive body G*mass + real(DP), dimension(:), intent(in), optional :: radius !! Array of massive body radii + real(DP), dimension(:,:), intent(inout) :: acc !! Acceleration vector array + end subroutine swiftest_kick_getacch_int_all_flat_pl + + module subroutine swiftest_kick_getacch_int_all_triangular_pl(npl, nplm, x, Gmass, radius, acc) + implicit none + integer(I4B), intent(in) :: npl !! Total number of massive bodies + integer(I4B), intent(in) :: nplm !! Number of fully interacting massive bodies + real(DP), dimension(:,:), intent(in) :: x !! Position vector array + real(DP), dimension(:), intent(in) :: Gmass !! Array of massive body G*mass + real(DP), dimension(:), intent(in), optional :: radius !! Array of massive body radii + real(DP), dimension(:,:), intent(inout) :: acc !! Acceleration vector array + end subroutine swiftest_kick_getacch_int_all_triangular_pl + + module subroutine swiftest_kick_getacch_int_all_tp(ntp, npl, xtp, xpl, GMpl, lmask, acc) + implicit none + integer(I4B), intent(in) :: ntp !! Number of test particles + integer(I4B), intent(in) :: npl !! Number of massive bodies + real(DP), dimension(:,:), intent(in) :: xtp !! Test particle position vector array + real(DP), dimension(:,:), intent(in) :: xpl !! Massive body particle position vector array + real(DP), dimension(:), intent(in) :: GMpl !! Array of massive body G*mass + logical, dimension(:), intent(in) :: lmask !! Logical mask indicating which test particles should be computed + real(DP), dimension(:,:), intent(inout) :: acc !! Acceleration vector array + end subroutine swiftest_kick_getacch_int_all_tp + + pure module subroutine swiftest_kick_getacch_int_one_pl(rji2, xr, yr, zr, Gmi, Gmj, axi, ayi, azi, axj, ayj, azj) + !$omp declare simd(swiftest_kick_getacch_int_one_pl) + implicit none + real(DP), intent(in) :: rji2 !! Square of distance between the two bodies + real(DP), intent(in) :: xr, yr, zr !! Distances between the two bodies in x, y, and z directions + real(DP), intent(in) :: Gmi !! G*mass of body i + real(DP), intent(in) :: Gmj !! G*mass of body j + real(DP), intent(inout) :: axi, ayi, azi !! Acceleration vector components of body i + real(DP), intent(inout) :: axj, ayj, azj !! Acceleration vector components of body j + end subroutine swiftest_kick_getacch_int_one_pl + + pure module subroutine swiftest_kick_getacch_int_one_tp(rji2, xr, yr, zr, Gmpl, ax, ay, az) + !$omp declare simd(swiftest_kick_getacch_int_one_tp) + implicit none + real(DP), intent(in) :: rji2 !! Square of distance between the test particle and massive body + real(DP), intent(in) :: xr, yr, zr !! Distances between the two bodies in x, y, and z directions + real(DP), intent(in) :: Gmpl !! G*mass of massive body + real(DP), intent(inout) :: ax, ay, az !! Acceleration vector components of test particle + end subroutine swiftest_kick_getacch_int_one_tp + + module function swiftest_io_netcdf_get_old_t_final_system(self, param) result(old_t_final) + implicit none + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + real(DP) :: old_t_final !! Final time from last run + end function swiftest_io_netcdf_get_old_t_final_system + + module subroutine swiftest_io_netcdf_initialize_output(self, param) + implicit none + class(swiftest_io_netcdf_parameters), intent(inout) :: self !! Parameters used to for writing a NetCDF dataset to file + class(base_parameters), intent(in) :: param !! Current run configuration parameters + end subroutine swiftest_io_netcdf_initialize_output + + module subroutine swiftest_io_netcdf_open(self, param, readonly) + implicit none + class(swiftest_io_netcdf_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset + class(base_parameters), intent(in) :: param !! Current run configuration parameters + logical, optional, intent(in) :: readonly !! Logical flag indicating that this should be open read only + end subroutine swiftest_io_netcdf_open + + module function swiftest_io_netcdf_read_frame_system(self, nc, param) result(ierr) + implicit none + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest system object + class(base_io_netcdf_parameters), intent(inout) :: nc !! Parameters used to for reading a NetCDF dataset to file + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + integer(I4B) :: ierr !! Error code: returns 0 if the read is successful + end function swiftest_io_netcdf_read_frame_system + + module subroutine swiftest_io_netcdf_read_hdr_system(self, nc, param) + implicit none + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object + class(base_io_netcdf_parameters), intent(inout) :: nc !! Parameters used to for reading a NetCDF dataset to file + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine swiftest_io_netcdf_read_hdr_system + + module subroutine swiftest_io_netcdf_read_particle_info_system(self, nc, param, plmask, tpmask) + implicit none + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object + class(base_io_netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular NetCDF dataset + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + logical, dimension(:), intent(in) :: plmask !! Logical array indicating which index values belong to massive bodies + logical, dimension(:), intent(in) :: tpmask !! Logical array indicating which index values belong to test particles + end subroutine swiftest_io_netcdf_read_particle_info_system + + module subroutine swiftest_io_netcdf_write_frame_body(self, nc, param) + implicit none + class(swiftest_body), intent(in) :: self !! Swiftest base object + class(base_io_netcdf_parameters), intent(inout) :: nc !! Parameters used to for writing a NetCDF dataset to file + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine swiftest_io_netcdf_write_frame_body + + module subroutine swiftest_io_netcdf_write_frame_system(self, nc, param) + implicit none + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest system object + class(base_io_netcdf_parameters), intent(inout) :: nc !! Parameters used to for writing a NetCDF dataset to file + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine swiftest_io_netcdf_write_frame_system + + module subroutine swiftest_io_netcdf_write_hdr_system(self, nc, param) + implicit none + class(swiftest_nbody_system), intent(in) :: self !! Swiftest nbody system object + class(base_io_netcdf_parameters), intent(inout) :: nc !! Parameters used to for writing a NetCDF dataset to file + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine swiftest_io_netcdf_write_hdr_system + + module subroutine swiftest_io_netcdf_write_info_body(self, nc, param) + implicit none + class(swiftest_body), intent(in) :: self !! Swiftest particle object + class(base_io_netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular NetCDF dataset + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine swiftest_io_netcdf_write_info_body + + module subroutine swiftest_io_write_discard(self, param) + implicit none + class(swiftest_nbody_system), intent(inout) :: self !! SyMBA nbody system object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine swiftest_io_write_discard + + module subroutine swiftest_obl_acc_body(self, system) + implicit none + class(swiftest_body), intent(inout) :: self !! Swiftest body object + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object + end subroutine swiftest_obl_acc_body + + module subroutine swiftest_obl_acc_pl(self, system) + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object + end subroutine swiftest_obl_acc_pl + + module subroutine swiftest_obl_acc_tp(self, system) + implicit none + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object + end subroutine swiftest_obl_acc_tp + + module subroutine swiftest_obl_pot_system(self) + implicit none + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object + end subroutine swiftest_obl_pot_system + + module subroutine swiftest_orbel_el2xv_vec(self, cb) + implicit none + class(swiftest_body), intent(inout) :: self !! Swiftest body object + class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object + end subroutine swiftest_orbel_el2xv_vec + + pure module subroutine swiftest_orbel_scget(angle, sx, cx) + !$omp declare simd(swiftest_orbel_scget) + implicit none + real(DP), intent(in) :: angle + real(DP), intent(out) :: sx, cx + end subroutine swiftest_orbel_scget + + pure elemental module subroutine swiftest_orbel_xv2aeq(mu, px, py, pz, vx, vy, vz, a, e, q) + !$omp declare simd(swiftest_orbel_xv2aeq) + implicit none + real(DP), intent(in) :: mu !! Gravitational constant + real(DP), intent(in) :: px,py,pz !! Position vector + real(DP), intent(in) :: vx,vy,vz !! Velocity vector + real(DP), intent(out) :: a !! semimajor axis + real(DP), intent(out) :: e !! eccentricity + real(DP), intent(out) :: q !! periapsis + end subroutine swiftest_orbel_xv2aeq + + pure module subroutine swiftest_orbel_xv2aqt(mu, px, py, pz, vx, vy, vz, a, q, capm, tperi) + !$omp declare simd(swiftest_orbel_xv2aqt) + implicit none + real(DP), intent(in) :: mu !! Gravitational constant + real(DP), intent(in) :: px,py,pz !! Position vector + real(DP), intent(in) :: vx,vy,vz !! Velocity vector + real(DP), intent(out) :: a !! semimajor axis + real(DP), intent(out) :: q !! periapsis + real(DP), intent(out) :: capm !! mean anomaly + real(DP), intent(out) :: tperi !! time of pericenter passage + end subroutine swiftest_orbel_xv2aqt + + pure module subroutine swiftest_orbel_xv2el(mu, px, py, pz, vx, vy, vz, a, e, inc, capom, omega, capm, varpi, lam, f, cape, capf) + implicit none + real(DP), intent(in) :: mu !! Gravitational constant + real(DP), intent(in) :: px,py,pz !! Position vector + real(DP), intent(in) :: vx,vy,vz !! Velocity vector + real(DP), intent(out) :: a !! semimajor axis + real(DP), intent(out) :: e !! eccentricity + real(DP), intent(out) :: inc !! inclination + real(DP), intent(out) :: capom !! longitude of ascending node + real(DP), intent(out) :: omega !! argument of periapsis + real(DP), intent(out) :: capm !! mean anomaly + real(DP), intent(out) :: varpi !! longitude of periapsis + real(DP), intent(out) :: lam !! mean longitude + real(DP), intent(out) :: f !! true anomaly + real(DP), intent(out) :: cape !! eccentric anomaly (eccentric orbits) + real(DP), intent(out) :: capf !! hyperbolic anomaly (hyperbolic orbits) + end subroutine swiftest_orbel_xv2el + + module subroutine swiftest_orbel_xv2el_vec(self, cb) + implicit none + class(swiftest_body), intent(inout) :: self !! Swiftest body object + class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object + end subroutine swiftest_orbel_xv2el_vec + + module subroutine swiftest_setup_body(self, n, param) + implicit none + class(swiftest_body), intent(inout) :: self !! Swiftest body object + integer(I4B), intent(in) :: n !! Number of particles to allocate space for + class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters + end subroutine swiftest_setup_body + + module subroutine swiftest_setup_construct_system(system, param) + implicit none + class(base_nbody_system), allocatable, intent(inout) :: system !! Swiftest system object + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine swiftest_setup_construct_system + + module subroutine swiftest_setup_initialize_particle_info_system(self, param) + implicit none + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine swiftest_setup_initialize_particle_info_system + + module subroutine swiftest_setup_initialize_system(self, param) + implicit none + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest system object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine swiftest_setup_initialize_system + + module subroutine swiftest_setup_pl(self, n, param) + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + integer(I4B), intent(in) :: n !! Number of particles to allocate space for + class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters + end subroutine swiftest_setup_pl + + module subroutine swiftest_setup_tp(self, n, param) + implicit none + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + integer(I4B), intent(in) :: n !! Number of particles to allocate space for + class(swiftest_parameters), intent(in) :: param !! Current run configuration parametersr + end subroutine swiftest_setup_tp + + ! TODO: Implement the tides model + module subroutine swiftest_tides_kick_getacch_pl(self, system) + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object + end subroutine swiftest_tides_kick_getacch_pl + + ! module subroutine swiftest_tides_step_spin_system(self, param, t, dt) + ! implicit none + ! class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object + ! class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters + ! real(DP), intent(in) :: t !! Simulation time + ! real(DP), intent(in) :: dt !! Current stepsize + ! end subroutine swiftest_tides_step_spin_system + + module subroutine swiftest_user_kick_getacch_body(self, system, param, t, lbeg) + implicit none + class(swiftest_body), intent(inout) :: self !! Swiftest massive body particle data structure + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody_system_object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + real(DP), intent(in) :: t !! Current time + logical, intent(in) :: lbeg !! Optional argument that determines whether or not this is the beginning or end of the step + end subroutine swiftest_user_kick_getacch_body + end interface + + interface util_append + module subroutine swiftest_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 swiftest_util_append_arr_char_string + + module subroutine swiftest_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 swiftest_util_append_arr_DP + + module subroutine swiftest_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 swiftest_util_append_arr_DPvec + + module subroutine swiftest_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 swiftest_util_append_arr_I4B + + module subroutine swiftest_util_append_arr_info(arr, source, nold, nsrc, lsource_mask) + implicit none + type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: arr !! Destination array + type(swiftest_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 swiftest_util_append_arr_info + + module subroutine swiftest_util_append_arr_kin(arr, source, nold, nsrc, lsource_mask) + implicit none + type(swiftest_kinship), dimension(:), allocatable, intent(inout) :: arr !! Destination array + type(swiftest_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 swiftest_util_append_arr_kin + + module subroutine swiftest_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 swiftest_util_append_arr_logical + end interface + + interface + module subroutine swiftest_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 + logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + end subroutine swiftest_util_append_body + + + module subroutine swiftest_util_append_pl(self, source, lsource_mask) + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + 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 swiftest_util_append_pl + + module subroutine swiftest_util_append_tp(self, source, lsource_mask) + implicit none + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + 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 swiftest_util_append_tp + + module subroutine swiftest_util_coord_b2h_pl(self, cb) + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object + end subroutine swiftest_util_coord_b2h_pl + + module subroutine swiftest_util_coord_b2h_tp(self, cb) + implicit none + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + class(swiftest_cb), intent(in) :: cb !! Swiftest central body object + end subroutine swiftest_util_coord_b2h_tp + + module subroutine swiftest_util_coord_h2b_pl(self, cb) + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object + end subroutine swiftest_util_coord_h2b_pl + + module subroutine swiftest_util_coord_h2b_tp(self, cb) + implicit none + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + class(swiftest_cb), intent(in) :: cb !! Swiftest central body object + end subroutine swiftest_util_coord_h2b_tp + + module subroutine swiftest_util_coord_vb2vh_pl(self, cb) + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object + end subroutine swiftest_util_coord_vb2vh_pl + + module subroutine swiftest_util_coord_vb2vh_tp(self, vbcb) + implicit none + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + real(DP), dimension(:), intent(in) :: vbcb !! Barycentric velocity of the central body + end subroutine swiftest_util_coord_vb2vh_tp + + module subroutine swiftest_util_coord_vh2vb_pl(self, cb) + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object + end subroutine swiftest_util_coord_vh2vb_pl + + module subroutine swiftest_util_coord_vh2vb_tp(self, vbcb) + implicit none + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + real(DP), dimension(:), intent(in) :: vbcb !! Barycentric velocity of the central body + end subroutine swiftest_util_coord_vh2vb_tp + + module subroutine swiftest_util_coord_rh2rb_pl(self, cb) + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object + end subroutine swiftest_util_coord_rh2rb_pl + + module subroutine swiftest_util_coord_rh2rb_tp(self, cb) + implicit none + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + class(swiftest_cb), intent(in) :: cb !! Swiftest central body object + end subroutine swiftest_util_coord_rh2rb_tp + + module subroutine swiftest_util_copy_particle_info(self, source) + implicit none + class(swiftest_particle_info), intent(inout) :: self + class(swiftest_particle_info), intent(in) :: source + end subroutine swiftest_util_copy_particle_info + + module subroutine swiftest_util_copy_particle_info_arr(source, dest, idx) + implicit none + class(swiftest_particle_info), dimension(:), intent(in) :: source !! Source object to copy into + class(swiftest_particle_info), dimension(:), intent(inout) :: dest !! Swiftest body object with particle metadata information object + integer(I4B), dimension(:), intent(in), optional :: idx !! Optional array of indices to draw the source object + end subroutine swiftest_util_copy_particle_info_arr + + module subroutine swiftest_util_dealloc_body(self) + implicit none + class(swiftest_body), intent(inout) :: self + end subroutine swiftest_util_dealloc_body + + module subroutine swiftest_util_dealloc_kin(self) + implicit none + class(swiftest_kinship), intent(inout) :: self !! Swiftest kinship object + end subroutine swiftest_util_dealloc_kin + + module subroutine swiftest_util_dealloc_pl(self) + implicit none + class(swiftest_pl), intent(inout) :: self + end subroutine swiftest_util_dealloc_pl + + module subroutine swiftest_util_final_kin(self) + implicit none + type(swiftest_kinship), intent(inout) :: self !! Swiftest kinship object + end subroutine swiftest_util_final_kin + + module subroutine swiftest_util_final_system(self) + implicit none + class(swiftest_nbody_system), intent(inout) :: self + end subroutine swiftest_util_final_system + + module subroutine swiftest_util_dealloc_tp(self) + implicit none + class(swiftest_tp), intent(inout) :: self + end subroutine swiftest_util_dealloc_tp + + module subroutine swiftest_util_exit(code) + implicit none + integer(I4B), intent(in) :: code !! Failure exit code + end subroutine swiftest_util_exit + + module subroutine swiftest_util_fill_body(self, inserts, lfill_list) + implicit none + class(swiftest_body), intent(inout) :: self !! Swiftest body object + class(swiftest_body), intent(in) :: inserts !! Swiftest body object to be inserted + logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps + end subroutine swiftest_util_fill_body + + + module subroutine swiftest_util_fill_pl(self, inserts, lfill_list) + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_body), intent(in) :: inserts !! Swiftest body object to be inserted + logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps + end subroutine swiftest_util_fill_pl + + module subroutine swiftest_util_fill_tp(self, inserts, lfill_list) + implicit none + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + class(swiftest_body), intent(in) :: inserts !! Swiftest body object to be inserted + logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps + end subroutine swiftest_util_fill_tp + end interface + + interface util_fill + module subroutine swiftest_util_fill_arr_char_string(keeps, inserts, lfill_list) + implicit none + character(len=STRMAX), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + character(len=STRMAX), 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 swiftest_util_fill_arr_char_string + + module subroutine swiftest_util_fill_arr_DP(keeps, inserts, lfill_list) + implicit none + real(DP), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + real(DP), 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 swiftest_util_fill_arr_DP + + module subroutine swiftest_util_fill_arr_DPvec(keeps, inserts, lfill_list) + implicit none + real(DP), dimension(:,:), allocatable, intent(inout) :: keeps !! Array of values to keep + real(DP), 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 swiftest_util_fill_arr_DPvec + + module subroutine swiftest_util_fill_arr_I4B(keeps, inserts, lfill_list) + implicit none + integer(I4B), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + integer(I4B), 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 swiftest_util_fill_arr_I4B + + module subroutine swiftest_util_fill_arr_info(keeps, inserts, lfill_list) + implicit none + type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + type(swiftest_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 swiftest_util_fill_arr_info + + module subroutine swiftest_util_fill_arr_kin(keeps, inserts, lfill_list) + implicit none + type(swiftest_kinship), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + type(swiftest_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 swiftest_util_fill_arr_kin + + module subroutine swiftest_util_fill_arr_logical(keeps, inserts, lfill_list) + implicit none + logical, dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + logical, 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 swiftest_util_fill_arr_logical + end interface + + interface + + module subroutine swiftest_util_final_storage(self) + implicit none + type(swiftest_storage(*)) :: self + end subroutine swiftest_util_final_storage + + pure module subroutine swiftest_util_flatten_eucl_ij_to_k(n, i, j, k) + !$omp declare simd(swiftest_util_flatten_eucl_ij_to_k) + implicit none + integer(I4B), intent(in) :: n !! Number of bodies + integer(I4B), intent(in) :: i !! Index of the ith body + integer(I4B), intent(in) :: j !! Index of the jth body + integer(I8B), intent(out) :: k !! Index of the flattened matrix + end subroutine swiftest_util_flatten_eucl_ij_to_k + + pure module subroutine swiftest_util_flatten_eucl_k_to_ij(n, k, i, j) + implicit none + integer(I4B), intent(in) :: n !! Number of bodies + integer(I8B), intent(in) :: k !! Index of the flattened matrix + integer(I4B), intent(out) :: i !! Index of the ith body + integer(I4B), intent(out) :: j !! Index of the jth body + end subroutine swiftest_util_flatten_eucl_k_to_ij + + module subroutine swiftest_util_flatten_eucl_plpl(self, param) + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine + + module subroutine swiftest_util_flatten_eucl_pltp(self, pl, param) + implicit none + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + class(swiftest_pl), intent(in) :: pl !! Swiftest massive body object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine + + module subroutine swiftest_util_get_vals_storage(self, idvals, tvals) + class(swiftest_storage(*)), intent(in) :: self !! Swiftest storage object + integer(I4B), dimension(:), allocatable, intent(out) :: idvals !! Array of all id values in all snapshots + real(DP), dimension(:), allocatable, intent(out) :: tvals !! Array of all time values in all snapshots + end subroutine swiftest_util_get_vals_storage + + module subroutine swiftest_util_index_array(ind_arr, n) + implicit none + integer(I4B), dimension(:), allocatable, intent(inout) :: ind_arr !! Index array. Input is a pre-existing index array where n /= size(ind_arr). Output is a new index array ind_arr = [1, 2, ... n] + integer(I4B), intent(in) :: n !! The new size of the index array + end subroutine swiftest_util_index_array + + module subroutine swiftest_util_index_map_storage(self) + implicit none + class(swiftest_storage(*)), intent(inout) :: self !! Swiftest storage object + end subroutine swiftest_util_index_map_storage + + module subroutine swiftest_util_minimize_bfgs(f, N, x0, eps, maxloop, lerr, x1) + use lambda_function + implicit none + integer(I4B), intent(in) :: N + class(lambda_obj), intent(inout) :: f + real(DP), dimension(:), intent(in) :: x0 + real(DP), intent(in) :: eps + logical, intent(out) :: lerr + integer(I4B), intent(in) :: maxloop + real(DP), dimension(:), allocatable, intent(out) :: x1 + end subroutine swiftest_util_minimize_bfgs + + module subroutine swiftest_util_peri_body(self, system, param) + implicit none + class(swiftest_body), intent(inout) :: self !! SyMBA massive body object + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters + end subroutine swiftest_util_peri_body + + module subroutine swiftest_util_peri_tp(self, system, param) + implicit none + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters + end subroutine swiftest_util_peri_tp + + module subroutine swiftest_util_rearray_pl(self, system, param) + implicit none + class(swiftest_pl), intent(inout) :: self !! SyMBA massive body object + class(swiftest_nbody_system), intent(inout) :: system !! SyMBA nbody system object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions + end subroutine swiftest_util_rearray_pl + + module subroutine swiftest_util_rescale_system(self, param, mscale, dscale, tscale) + implicit none + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters. Returns with new values of the scale vactors and GU + real(DP), intent(in) :: mscale, dscale, tscale !! Scale factors for mass, distance, and time units, respectively. + end subroutine swiftest_util_rescale_system + + module subroutine swiftest_util_reset_kinship_pl(self, idx) + implicit none + class(swiftest_pl), intent(inout) :: self !! SyMBA massive body object + integer(I4B), dimension(:), intent(in) :: idx !! Index array of bodies to reset + end subroutine swiftest_util_reset_kinship_pl + + module subroutine swiftest_util_reset_storage(self) + implicit none + class(swiftest_storage(*)), intent(inout) :: self !! Swiftest storage object + end subroutine swiftest_util_reset_storage + end interface + + + interface util_resize + module subroutine swiftest_util_resize_arr_char_string(arr, nnew) + implicit none + character(len=STRMAX), dimension(:), allocatable, intent(inout) :: arr !! Array to resize + integer(I4B), intent(in) :: nnew !! New size + end subroutine swiftest_util_resize_arr_char_string + + module subroutine swiftest_util_resize_arr_DP(arr, nnew) + implicit none + real(DP), dimension(:), allocatable, intent(inout) :: arr !! Array to resize + integer(I4B), intent(in) :: nnew !! New size + end subroutine swiftest_util_resize_arr_DP + + module subroutine swiftest_util_resize_arr_DPvec(arr, nnew) + implicit none + real(DP), dimension(:,:), allocatable, intent(inout) :: arr !! Array to resize + integer(I4B), intent(in) :: nnew !! New size + end subroutine swiftest_util_resize_arr_DPvec + + module subroutine swiftest_util_resize_arr_I4B(arr, nnew) + implicit none + integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Array to resize + integer(I4B), intent(in) :: nnew !! New size + end subroutine swiftest_util_resize_arr_I4B + + module subroutine swiftest_util_resize_arr_info(arr, nnew) + implicit none + type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: arr !! Array to resize + integer(I4B), intent(in) :: nnew !! New size + end subroutine swiftest_util_resize_arr_info + + module subroutine swiftest_util_resize_arr_kin(arr, nnew) + implicit none + type(swiftest_kinship), dimension(:), allocatable, intent(inout) :: arr !! Array to resize + integer(I4B), intent(in) :: nnew !! New size + end subroutine swiftest_util_resize_arr_kin + + module subroutine swiftest_util_resize_arr_logical(arr, nnew) + implicit none + logical, dimension(:), allocatable, intent(inout) :: arr !! Array to resize + integer(I4B), intent(in) :: nnew !! New size + end subroutine swiftest_util_resize_arr_logical + end interface + + interface + module subroutine swiftest_util_resize_body(self, nnew) + implicit none + class(swiftest_body), intent(inout) :: self !! Swiftest body object + integer(I4B), intent(in) :: nnew !! New size neded + end subroutine swiftest_util_resize_body + + module subroutine swiftest_util_resize_pl(self, nnew) + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + integer(I4B), intent(in) :: nnew !! New size neded + end subroutine swiftest_util_resize_pl + + module subroutine swiftest_util_resize_tp(self, nnew) + implicit none + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + integer(I4B), intent(in) :: nnew !! New size neded + end subroutine swiftest_util_resize_tp + + module subroutine swiftest_util_get_energy_momentum_system(self, param) + implicit none + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object + class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters + end subroutine swiftest_util_get_energy_momentum_system + + module subroutine swiftest_util_get_idvalues_system(self, idvals) + implicit none + class(swiftest_nbody_system), intent(in) :: self !! Encounter snapshot object + integer(I4B), dimension(:), allocatable, intent(out) :: idvals !! Array of all id values saved in this snapshot + end subroutine swiftest_util_get_idvalues_system + + module subroutine swiftest_util_set_beg_end_pl(self, rbeg, rend, vbeg) + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + real(DP), dimension(:,:), intent(in), optional :: rbeg !! Position vectors at beginning of step + real(DP), dimension(:,:), intent(in), optional :: rend !! Positions vectors at end of step + real(DP), dimension(:,:), intent(in), optional :: vbeg !! vbeg is an unused variable to keep this method forward compatible with RMVS + end subroutine swiftest_util_set_beg_end_pl + + module subroutine swiftest_util_set_ir3h(self) + implicit none + class(swiftest_body), intent(inout) :: self !! Swiftest body object + end subroutine swiftest_util_set_ir3h + + module subroutine swiftest_util_set_msys(self) + implicit none + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest system object + end subroutine swiftest_util_set_msys + + module subroutine swiftest_util_set_mu_pl(self, cb) + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object + end subroutine swiftest_util_set_mu_pl + + module subroutine swiftest_util_set_mu_tp(self, cb) + implicit none + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object + end subroutine swiftest_util_set_mu_tp + + module subroutine swiftest_util_set_particle_info(self, name, particle_type, status, origin_type, origin_time, collision_id, & + origin_rh, origin_vh, discard_time, discard_rh, discard_vh, discard_body_id) + implicit none + class(swiftest_particle_info), intent(inout) :: self + character(len=*), intent(in), optional :: name !! Non-unique name + character(len=*), intent(in), optional :: particle_type !! String containing a description of the particle type (e.g. Central Body, Massive Body, Test Particle) + character(len=*), intent(in), optional :: status !! Particle status description: Active, Merged, Fragmented, etc. + character(len=*), intent(in), optional :: origin_type !! String containing a description of the origin of the particle (e.g. Initial Conditions, Supercatastrophic, Disruption, etc.) + real(DP), intent(in), optional :: origin_time !! The time of the particle's formation + integer(I4B), intent(in), optional :: collision_id !! The ID fo the collision that formed the particle + real(DP), dimension(:), intent(in), optional :: origin_rh !! The heliocentric distance vector at the time of the particle's formation + real(DP), dimension(:), intent(in), optional :: origin_vh !! The heliocentric velocity vector at the time of the particle's formation + real(DP), intent(in), optional :: discard_time !! The time of the particle's discard + real(DP), dimension(:), intent(in), optional :: discard_rh !! The heliocentric distance vector at the time of the particle's discard + real(DP), dimension(:), intent(in), optional :: discard_vh !! The heliocentric velocity vector at the time of the particle's discard + integer(I4B), intent(in), optional :: discard_body_id !! The id of the other body involved in the discard (0 if no other body involved) + end subroutine swiftest_util_set_particle_info + + module subroutine swiftest_util_set_rhill(self,cb) + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object + end subroutine swiftest_util_set_rhill + + module subroutine swiftest_util_set_renc_I4B(self, scale) + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + integer(I4B), intent(in) :: scale !! Input scale factor (multiplier of Hill's sphere size) + end subroutine swiftest_util_set_renc_I4B + + module subroutine swiftest_util_set_renc_DP(self, scale) + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + real(DP), intent(in) :: scale !! Input scale factor (multiplier of Hill's sphere size) + end subroutine swiftest_util_set_renc_DP + + module subroutine swiftest_util_set_rhill_approximate(self,cb) + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object + end subroutine swiftest_util_set_rhill_approximate + + module subroutine swiftest_util_snapshot_system(self, param, system, t, arg) + implicit none + class(swiftest_storage(*)), intent(inout) :: self !! Swiftest storage object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object to store + real(DP), intent(in), optional :: t !! Time of snapshot if different from system time + character(*), intent(in), optional :: arg !! Optional argument (needed for extended storage type used in encounter snapshots) + end subroutine swiftest_util_snapshot_system + end interface + + + interface util_solve_linear_system + module function util_solve_linear_system_d(A,b,n,lerr) result(x) + implicit none + integer(I4B), intent(in) :: n + real(DP), dimension(:,:), intent(in) :: A + real(DP), dimension(:), intent(in) :: b + logical, intent(out) :: lerr + real(DP), dimension(n) :: x + end function util_solve_linear_system_d + + module function util_solve_linear_system_q(A,b,n,lerr) result(x) + implicit none + integer(I4B), intent(in) :: n + real(QP), dimension(:,:), intent(in) :: A + real(QP), dimension(:), intent(in) :: b + logical, intent(out) :: lerr + real(QP), dimension(n) :: x + end function util_solve_linear_system_q + end interface + + interface + module function util_solve_rkf45(f, y0in, t1, dt0, tol) result(y1) + use lambda_function + implicit none + class(lambda_obj), intent(inout) :: f !! lambda function object that has been initialized to be a function of derivatives. The object will return with components lastarg and lasteval set + real(DP), dimension(:), intent(in) :: y0in !! Initial value at t=0 + real(DP), intent(in) :: t1 !! Final time + real(DP), intent(in) :: dt0 !! Initial step size guess + real(DP), intent(in) :: tol !! Tolerance on solution + real(DP), dimension(:), allocatable :: y1 !! Final result + end function util_solve_rkf45 + end interface + + interface util_sort + pure module subroutine swiftest_util_sort_i4b(arr) + implicit none + integer(I4B), dimension(:), intent(inout) :: arr + end subroutine swiftest_util_sort_i4b + + pure module subroutine swiftest_util_sort_index_i4b(arr,ind) + implicit none + integer(I4B), dimension(:), intent(in) :: arr + integer(I4B), dimension(:), allocatable, intent(inout) :: ind + end subroutine swiftest_util_sort_index_i4b + + pure module subroutine swiftest_util_sort_index_I4B_I8Bind(arr,ind) + implicit none + integer(I4B), dimension(:), intent(in) :: arr + integer(I8B), dimension(:), allocatable, intent(inout) :: ind + end subroutine swiftest_util_sort_index_I4b_I8Bind + + pure module subroutine swiftest_util_sort_index_I8B_I8Bind(arr,ind) + implicit none + integer(I8B), dimension(:), intent(in) :: arr + integer(I8B), dimension(:), allocatable, intent(inout) :: ind + end subroutine swiftest_util_sort_index_I8B_I8Bind + + pure module subroutine swiftest_util_sort_sp(arr) + implicit none + real(SP), dimension(:), intent(inout) :: arr + end subroutine swiftest_util_sort_sp + + pure module subroutine swiftest_util_sort_index_sp(arr,ind) + implicit none + real(SP), dimension(:), intent(in) :: arr + integer(I4B), dimension(:), allocatable, intent(inout) :: ind + end subroutine swiftest_util_sort_index_sp + + pure module subroutine swiftest_util_sort_dp(arr) + implicit none + real(DP), dimension(:), intent(inout) :: arr + end subroutine swiftest_util_sort_dp + + pure module subroutine swiftest_util_sort_index_dp(arr,ind) + implicit none + real(DP), dimension(:), intent(in) :: arr + integer(I4B), dimension(:), allocatable, intent(inout) :: ind + end subroutine swiftest_util_sort_index_dp + end interface util_sort + + interface util_sort_rearrange + pure module subroutine swiftest_util_sort_rearrange_arr_char_string(arr, ind, n) + implicit none + character(len=STRMAX), dimension(:), allocatable, intent(inout) :: arr !! Destination array + integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against + integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange + end subroutine swiftest_util_sort_rearrange_arr_char_string + + pure module subroutine swiftest_util_sort_rearrange_arr_DP(arr, ind, n) + implicit none + real(DP), dimension(:), allocatable, intent(inout) :: arr !! Destination array + integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against + integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange + end subroutine swiftest_util_sort_rearrange_arr_DP + + pure module subroutine swiftest_util_sort_rearrange_arr_DPvec(arr, ind, n) + implicit none + real(DP), dimension(:,:), allocatable, intent(inout) :: arr !! Destination array + integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against + integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange + end subroutine swiftest_util_sort_rearrange_arr_DPvec + + pure module subroutine swiftest_util_sort_rearrange_arr_I4B(arr, ind, n) + implicit none + integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Destination array + integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against + integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange + end subroutine swiftest_util_sort_rearrange_arr_I4B + + pure module subroutine swiftest_util_sort_rearrange_arr_I4B_I8Bind(arr, ind, n) + implicit none + integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Destination array + integer(I8B), dimension(:), intent(in) :: ind !! Index to rearrange against + integer(I8B), intent(in) :: n !! Number of elements in arr and ind to rearrange + end subroutine swiftest_util_sort_rearrange_arr_I4B_I8Bind + + module subroutine swiftest_util_sort_rearrange_arr_info(arr, ind, n) + implicit none + type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: arr !! Destination array + integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against + integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange + end subroutine swiftest_util_sort_rearrange_arr_info + + pure module subroutine swiftest_util_sort_rearrange_arr_kin(arr, ind, n) + implicit none + type(swiftest_kinship), dimension(:), allocatable, intent(inout) :: arr !! Destination array + integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against + integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange + end subroutine swiftest_util_sort_rearrange_arr_kin + + pure module subroutine swiftest_util_sort_rearrange_arr_logical(arr, ind, n) + implicit none + logical, dimension(:), allocatable, intent(inout) :: arr !! Destination array + integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against + integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange + end subroutine swiftest_util_sort_rearrange_arr_logical + + pure module subroutine swiftest_util_sort_rearrange_arr_logical_I8Bind(arr, ind, n) + implicit none + logical, dimension(:), allocatable, intent(inout) :: arr !! Destination array + integer(I8B), dimension(:), intent(in) :: ind !! Index to rearrange against + integer(I8B), intent(in) :: n !! Number of elements in arr and ind to rearrange + end subroutine swiftest_util_sort_rearrange_arr_logical_I8Bind + end interface util_sort_rearrange + + interface + module subroutine swiftest_util_sort_rearrange_body(self, ind) + implicit none + class(swiftest_body), intent(inout) :: self !! Swiftest 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 swiftest_util_sort_rearrange_body + + module subroutine swiftest_util_sort_rearrange_pl(self, ind) + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest 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 swiftest_util_sort_rearrange_pl + + module subroutine swiftest_util_sort_rearrange_tp(self, ind) + implicit none + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle 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 swiftest_util_sort_rearrange_tp + + module subroutine swiftest_util_sort_body(self, sortby, ascending) + implicit none + class(swiftest_body), intent(inout) :: self !! Swiftest body object + character(*), intent(in) :: sortby !! Sorting attribute + logical, intent(in) :: ascending !! Logical flag indicating whether or not the sorting should be in ascending or descending order + end subroutine swiftest_util_sort_body + + module subroutine swiftest_util_sort_pl(self, sortby, ascending) + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest body object + character(*), intent(in) :: sortby !! Sorting attribute + logical, intent(in) :: ascending !! Logical flag indicating whether or not the sorting should be in ascending or descending order + end subroutine swiftest_util_sort_pl + + module subroutine swiftest_util_sort_tp(self, sortby, ascending) + implicit none + class(swiftest_tp), intent(inout) :: self !! Swiftest body object + character(*), intent(in) :: sortby !! Sorting attribute + logical, intent(in) :: ascending !! Logical flag indicating whether or not the sorting should be in ascending or descending order + end subroutine swiftest_util_sort_tp + + end interface + + interface util_spill + module subroutine swiftest_util_spill_arr_char_string(keeps, discards, lspill_list, ldestructive) + implicit none + character(len=STRMAX), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + character(len=STRMAX), 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 swiftest_util_spill_arr_char_string + + module subroutine swiftest_util_spill_arr_DP(keeps, discards, lspill_list, ldestructive) + implicit none + real(DP), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + real(DP), dimension(:), allocatable, intent(inout) :: discards !! Array of discards + 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 swiftest_util_spill_arr_DP + + module subroutine swiftest_util_spill_arr_DPvec(keeps, discards, lspill_list, ldestructive) + implicit none + real(DP), dimension(:,:), allocatable, intent(inout) :: keeps !! Array of values to keep + real(DP), dimension(:,:), allocatable, intent(inout) :: discards !! Array discards + 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 swiftest_util_spill_arr_DPvec + + module subroutine swiftest_util_spill_arr_I4B(keeps, discards, lspill_list, ldestructive) + implicit none + integer(I4B), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + integer(I4B), 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 swiftest_util_spill_arr_I4B + + module subroutine swiftest_util_spill_arr_I8B(keeps, discards, lspill_list, ldestructive) + implicit none + integer(I8B), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + integer(I8B), 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 swiftest_util_spill_arr_I8B + + module subroutine swiftest_util_spill_arr_info(keeps, discards, lspill_list, ldestructive) + implicit none + type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + type(swiftest_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 swiftest_util_spill_arr_info + + module subroutine swiftest_util_spill_arr_kin(keeps, discards, lspill_list, ldestructive) + implicit none + type(swiftest_kinship), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + type(swiftest_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 swiftest_util_spill_arr_kin + + module subroutine swiftest_util_spill_arr_logical(keeps, discards, lspill_list, ldestructive) + implicit none + logical, dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + logical, 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 swiftest_util_spill_arr_logical + end interface + + interface + module subroutine swiftest_util_spill_body(self, discards, lspill_list, ldestructive) + implicit none + class(swiftest_body), intent(inout) :: self !! Swiftest 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 swiftest_util_spill_body + + module subroutine swiftest_util_spill_pl(self, discards, lspill_list, ldestructive) + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest 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 swiftest_util_spill_pl + + module subroutine swiftest_util_spill_tp(self, discards, lspill_list, ldestructive) + implicit none + class(swiftest_tp), intent(inout) :: self !! Swiftest 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 swiftest_util_spill_tp + + end interface + + interface util_unique + module subroutine swiftest_util_unique_DP(input_array, output_array, index_map) + implicit none + real(DP), dimension(:), intent(in) :: input_array !! Unsorted input array + real(DP), dimension(:), allocatable, intent(out) :: output_array !! Sorted array of unique values + integer(I4B), dimension(:), allocatable, intent(out) :: index_map !! An array of the same size as input_array that such that any for any index i, output_array(index_map(i)) = input_array(i) + end subroutine swiftest_util_unique_DP + + module subroutine swiftest_util_unique_I4B(input_array, output_array, index_map) + implicit none + integer(I4B), dimension(:), intent(in) :: input_array !! Unsorted input array + integer(I4B), dimension(:), allocatable, intent(out) :: output_array !! Sorted array of unique values + integer(I4B), dimension(:), allocatable, intent(out) :: index_map !! An array of the same size as input_array that such that any for any index i, output_array(index_map(i)) = input_array(i) + end subroutine swiftest_util_unique_I4B + end interface util_unique + + interface + module subroutine swiftest_util_valid_id_system(self, param) + implicit none + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + end subroutine swiftest_util_valid_id_system + + module subroutine swiftest_util_version() + implicit none + end subroutine swiftest_util_version + end interface + + contains + subroutine make_impactors_pl(self, idx) + implicit none + class(swiftest_pl), intent(inout) :: self !! Massive body object + integer(I4B), dimension(:), intent(in) :: idx !! Array holding the indices of the two bodies involved in the collision) + + call collision_resolve_make_impactors_pl(self, idx) + + return + end subroutine make_impactors_pl + end module swiftest diff --git a/src/modules/swiftest_classes.f90 b/src/modules/swiftest_classes.f90 deleted file mode 100644 index 813426dc7..000000000 --- a/src/modules/swiftest_classes.f90 +++ /dev/null @@ -1,2007 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -module swiftest_classes - !! author: The Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott - !! - !! Definition of data and structures generic to all integrators. - !! Adapted from David E. Kaufmann's Swifter routine: module_swifter.f90 - use swiftest_globals - implicit none - public - - !> NetCDF variable names and constants - - !! This derived datatype stores the NetCDF ID values for each of the variables included in the NetCDF data file. This is used as the base class defined in swiftest_classes - type :: netcdf_variables - character(STRMAX) :: file_name !! Name of the output file - integer(I4B) :: out_type !! output type (will be assigned either NF90_DOUBLE or NF90_FLOAT, depending on the user parameter) - integer(I4B) :: id !! ID for the output file - integer(I4B) :: discard_body_id_varid !! ID for the id of the other body involved in the discard - integer(I4B) :: id_chunk !! Chunk size for the id dimension variables - integer(I4B) :: time_chunk !! Chunk size for the time dimension variables - logical :: lpseudo_vel_exists = .false. !! Logical flag to indicate whether or not the pseudovelocity vectors were present in an old file. - - ! Dimension ids and variable names - character(NAMELEN) :: str_dimname = "string32" !! name of the character string dimension - integer(I4B) :: str_dimid !! ID for the character string dimension - character(NAMELEN) :: time_dimname = "time" !! name of the time dimension - integer(I4B) :: time_dimid !! ID for the time dimension - integer(I4B) :: time_varid !! ID for the time variable - character(NAMELEN) :: name_dimname = "name" !! name of the particle name dimension - integer(I4B) :: name_dimid !! ID for the particle name dimension - integer(I4B) :: name_varid !! ID for the particle name variable - character(NAMELEN) :: space_dimname = "space" !! name of the space dimension - integer(I4B) :: space_dimid !! ID for the space dimension - integer(I4B) :: space_varid !! ID for the space variable - character(len=1), dimension(3) :: space_coords = ["x","y","z"] !! The space dimension coordinate labels - - ! Non-dimension ids and variable names - character(NAMELEN) :: ptype_varname = "particle_type" !! name of the particle type variable - integer(I4B) :: ptype_varid !! ID for the particle type variable - character(NAMELEN) :: id_varname = "id" !! name of the particle id variable - integer(I4B) :: id_varid !! ID for the id variable - character(NAMELEN) :: npl_varname = "npl" !! name of the number of active massive bodies variable - integer(I4B) :: npl_varid !! ID for the number of active massive bodies variable - character(NAMELEN) :: ntp_varname = "ntp" !! name of the number of active test particles variable - integer(I4B) :: ntp_varid !! ID for the number of active test particles variable - character(NAMELEN) :: nplm_varname = "nplm" !! name of the number of active fully interacting massive bodies variable (SyMBA) - integer(I4B) :: nplm_varid !! ID for the number of active fully interacting massive bodies variable (SyMBA) - character(NAMELEN) :: a_varname = "a" !! name of the semimajor axis variable - integer(I4B) :: a_varid !! ID for the semimajor axis variable - character(NAMELEN) :: e_varname = "e" !! name of the eccentricity variable - integer(I4B) :: e_varid !! ID for the eccentricity variable - character(NAMELEN) :: inc_varname = "inc" !! name of the inclination variable - integer(I4B) :: inc_varid !! ID for the inclination variable - character(NAMELEN) :: capom_varname = "capom" !! name of the long. asc. node variable - integer(I4B) :: capom_varid !! ID for the long. asc. node variable - character(NAMELEN) :: omega_varname = "omega" !! name of the arg. of periapsis variable - integer(I4B) :: omega_varid !! ID for the arg. of periapsis variable - character(NAMELEN) :: capm_varname = "capm" !! name of the mean anomaly variable - integer(I4B) :: capm_varid !! ID for the mean anomaly variable - character(NAMELEN) :: varpi_varname = "varpi" !! name of the long. of periapsis variable - integer(I4B) :: varpi_varid !! ID for the long. of periapsis variable - character(NAMELEN) :: lam_varname = "lam" !! name of the mean longitude variable - integer(I4B) :: lam_varid !! ID for the mean longitude variable - character(NAMELEN) :: f_varname = "f" !! name of the true anomaly variable - integer(I4B) :: f_varid !! ID for the true anomaly variable - character(NAMELEN) :: cape_varname = "cape" !! name of the eccentric anomaly variable - integer(I4B) :: cape_varid !! ID for the eccentric anomaly variable - character(NAMELEN) :: rh_varname = "rh" !! name of the heliocentric position vector variable - integer(I4B) :: rh_varid !! ID for the heliocentric position vector variable - character(NAMELEN) :: vh_varname = "vh" !! name of the heliocentric velocity vector variable - integer(I4B) :: vh_varid !! ID for the heliocentric velocity vector variable - character(NAMELEN) :: gr_pseudo_vh_varname = "gr_pseudo_vh" !! name of the heliocentric pseudovelocity vector variable (used in GR only) - integer(I4B) :: gr_pseudo_vh_varid !! ID for the heliocentric pseudovelocity vector variable (used in GR) - character(NAMELEN) :: gmass_varname = "Gmass" !! name of the mass variable - integer(I4B) :: Gmass_varid !! ID for the mass variable - character(NAMELEN) :: rhill_varname = "rhill" !! name of the hill radius variable - integer(I4B) :: rhill_varid !! ID for the hill radius variable - character(NAMELEN) :: radius_varname = "radius" !! name of the radius variable - integer(I4B) :: radius_varid !! ID for the radius variable - character(NAMELEN) :: Ip_varname = "Ip" !! name of the principal moment of inertial variable - integer(I4B) :: Ip_varid !! ID for the axis principal moment of inertia variable - character(NAMELEN) :: rot_varname = "rot" !! name of the rotation vector variable - integer(I4B) :: rot_varid !! ID for the rotation vector variable - character(NAMELEN) :: j2rp2_varname = "j2rp2" !! name of the j2rp2 variable - integer(I4B) :: j2rp2_varid !! ID for the j2 variable - character(NAMELEN) :: j4rp4_varname = "j4rp4" !! name of the j4pr4 variable - integer(I4B) :: j4rp4_varid !! ID for the j4 variable - character(NAMELEN) :: k2_varname = "k2" !! name of the Love number variable - integer(I4B) :: k2_varid !! ID for the Love number variable - character(NAMELEN) :: q_varname = "Q" !! name of the energy dissipation variable - integer(I4B) :: Q_varid !! ID for the energy dissipation variable - character(NAMELEN) :: ke_orb_varname = "KE_orb" !! name of the system orbital kinetic energy variable - integer(I4B) :: KE_orb_varid !! ID for the system orbital kinetic energy variable - character(NAMELEN) :: ke_spin_varname = "KE_spin" !! name of the system spin kinetic energy variable - integer(I4B) :: KE_spin_varid !! ID for the system spin kinetic energy variable - character(NAMELEN) :: pe_varname = "PE" !! name of the system potential energy variable - integer(I4B) :: PE_varid !! ID for the system potential energy variable - character(NAMELEN) :: L_orb_varname = "L_orb" !! name of the orbital angular momentum vector variable - integer(I4B) :: L_orb_varid !! ID for the system orbital angular momentum vector variable - character(NAMELEN) :: Lspin_varname = "Lspin" !! name of the spin angular momentum vector variable - integer(I4B) :: Lspin_varid !! ID for the system spin angular momentum vector variable - character(NAMELEN) :: L_escape_varname = "L_escape" !! name of the escaped angular momentum vector variable - integer(I4B) :: L_escape_varid !! ID for the escaped angular momentum vector variable - character(NAMELEN) :: Ecollisions_varname = "Ecollisions" !! name of the escaped angular momentum y variable - integer(I4B) :: Ecollisions_varid !! ID for the energy lost in collisions variable - character(NAMELEN) :: Euntracked_varname = "Euntracked" !! name of the energy that is untracked due to loss (untracked potential energy due to mergers and body energy for escaped bodies) - integer(I4B) :: Euntracked_varid !! ID for the energy that is untracked due to loss (untracked potential energy due to mergers and body energy for escaped bodies) - character(NAMELEN) :: GMescape_varname = "GMescape" !! name of the G*Mass of bodies that escape the system - integer(I4B) :: GMescape_varid !! ID for the G*Mass of bodies that escape the system - character(NAMELEN) :: origin_type_varname = "origin_type" !! name of the origin type variable (Initial Conditions, Disruption, etc.) - integer(I4B) :: origin_type_varid !! ID for the origin type - character(NAMELEN) :: origin_time_varname = "origin_time" !! name of the time of origin variable - integer(I4B) :: origin_time_varid !! ID for the origin time - character(NAMELEN) :: collision_id_varname = "collision_id" !! name of the collision id variable - integer(I4B) :: collision_id_varid !! Netcdf ID for the origin collision ID - character(NAMELEN) :: origin_rh_varname = "origin_rh" !! name of the heliocentric position vector of the body at the time of origin variable - integer(I4B) :: origin_rh_varid !! ID for the origin position vector variable - character(NAMELEN) :: origin_vh_varname = "origin_vh" !! name of the heliocentric velocity vector of the body at the time of origin variable - integer(I4B) :: origin_vh_varid !! ID for the origin velocity vector component - character(NAMELEN) :: discard_time_varname = "discard_time" !! name of the time of discard variable - integer(I4B) :: discard_time_varid !! ID for the time of discard variable - character(NAMELEN) :: discard_rh_varname = "discard_rh" !! name of the heliocentric position vector of the body at the time of discard variable - integer(I4B) :: discard_rh_varid !! ID for the heliocentric position vector of the body at the time of discard variable - character(NAMELEN) :: discard_vh_varname = "discard_vh" !! name of the heliocentric velocity vector of the body at the time of discard variable - integer(I4B) :: discard_vh_varid !! ID for the heliocentric velocity vector of the body at the time of discard variable - character(NAMELEN) :: discard_body_id_varname = "discard_body_id" !! name of the id of the other body involved in the discard - end type netcdf_variables - - type, extends(netcdf_variables) :: netcdf_parameters - contains - procedure :: close => netcdf_close !! Closes an open NetCDF file - procedure :: flush => netcdf_flush !! Flushes the current buffer to disk by closing and re-opening the file. - procedure :: initialize => netcdf_initialize_output !! Initialize a set of parameters used to identify a NetCDF output object - procedure :: open => netcdf_open !! Opens a NetCDF file - procedure :: sync => netcdf_sync !! Syncrhonize the disk and memory buffer of the NetCDF file (e.g. commit the frame files stored in memory to disk) - end type netcdf_parameters - - type swiftest_storage_frame - class(*), allocatable :: item - contains - procedure :: store => util_copy_store !! Stores a snapshot of the nbody system so that later it can be retrieved for saving to file. - generic :: assignment(=) => store - final :: util_final_storage_frame - end type - - type :: swiftest_storage(nframes) - !! An class that establishes the pattern for various storage objects - integer(I4B), len :: nframes = 4096 !! Total number of frames that can be stored - type(swiftest_storage_frame), dimension(nframes) :: frame !! Array of stored frames - integer(I4B) :: iframe = 0 !! Index of the last frame stored in the system - integer(I4B) :: nid !! Number of unique id values in all saved snapshots - integer(I4B), dimension(:), allocatable :: idvals !! The set of unique id values contained in the snapshots - integer(I4B), dimension(:), allocatable :: idmap !! The id value -> index map - integer(I4B) :: nt !! Number of unique time values in all saved snapshots - real(DP), dimension(:), allocatable :: tvals !! The set of unique time values contained in the snapshots - integer(I4B), dimension(:), allocatable :: tmap !! The t value -> index map - class(netcdf_parameters), allocatable :: nc !! NetCDF object attached to this storage object - contains - procedure :: dump => io_dump_storage !! Dumps storage object contents to file - procedure :: get_index_values => util_get_vals_storage !! Gets the unique values of the indices of a storage object (i.e. body id or time value) - procedure :: make_index_map => util_index_map_storage !! Maps body id values to storage index values so we don't have to use unlimited dimensions for id - procedure :: reset => util_reset_storage !! Resets a storage object by deallocating all items and resetting the frame counter to 0 - procedure :: take_snapshot => util_snapshot_system !! Takes a snapshot of the system for later file storage - final :: util_final_storage - end type swiftest_storage - - !******************************************************************************************************************************** - ! swiftest_parameters class definitions - !******************************************************************************************************************************** - - !> User defined parameters that are read in from the parameters input file. - !> Each paramter is initialized to a default values. - type :: swiftest_parameters - character(len=:), allocatable :: integrator !! Symbolic name of the nbody integrator used - character(len=:), allocatable :: param_file_name !! The name of the parameter file - integer(I4B) :: maxid = -1 !! The current maximum particle id number - integer(I4B) :: maxid_collision = 0 !! The current maximum collision id number - real(DP) :: t0 = 0.0_DP !! Integration reference time - real(DP) :: tstart = -1.0_DP !! Integration start time - real(DP) :: tstop = -1.0_DP !! Integration stop time - real(DP) :: dt = -1.0_DP !! Time step - integer(I8B) :: iloop = 0_I8B !! Main loop counter - integer(I4B) :: ioutput = 1 !! Output counter - character(STRMAX) :: incbfile = CB_INFILE !! Name of input file for the central body - character(STRMAX) :: inplfile = PL_INFILE !! Name of input file for massive bodies - character(STRMAX) :: intpfile = TP_INFILE !! Name of input file for test particles - character(STRMAX) :: in_netcdf = NC_INFILE !! Name of system input file for NetCDF input - character(STRMAX) :: in_type = "ASCII" !! Data representation type of input data files - character(STRMAX) :: in_form = "XV" !! Format of input data files ("EL" or "XV") - integer(I4B) :: istep_out = -1 !! Number of time steps between saved outputs - character(STRMAX) :: outfile = BIN_OUTFILE !! Name of output binary file - character(STRMAX) :: out_type = "NETCDF_DOUBLE" !! Binary format of output file - character(STRMAX) :: out_form = "XVEL" !! Data to write to output file - character(STRMAX) :: out_stat = 'NEW' !! Open status for output binary file - integer(I4B) :: dump_cadence = 10 !! Number of output steps between dumping simulation data to file - real(DP) :: rmin = -1.0_DP !! Minimum heliocentric radius for test particle - real(DP) :: rmax = -1.0_DP !! Maximum heliocentric radius for test particle - real(DP) :: rmaxu = -1.0_DP !! Maximum unbound heliocentric radius for test particle - real(DP) :: qmin = -1.0_DP !! Minimum pericenter distance for test particle - character(STRMAX) :: qmin_coord = 'HELIO' !! Coordinate frame to use for qmin - real(DP) :: qmin_alo = -1.0_DP !! Minimum semimajor axis for qmin - real(DP) :: qmin_ahi = -1.0_DP !! Maximum semimajor axis for qmin - real(QP) :: MU2KG = -1.0_QP !! Converts mass units to grams - real(QP) :: TU2S = -1.0_QP !! Converts time units to seconds - real(QP) :: DU2M = -1.0_QP !! Converts distance unit to centimeters - real(DP) :: GU = -1.0_DP !! Universal gravitational constant in the system units - real(DP) :: inv_c2 = -1.0_DP !! Inverse speed of light squared in the system units - character(NAMELEN) :: interaction_loops = "ADAPTIVE" !! Method used to compute interaction loops. Options are "TRIANGULAR", "FLAT", or "ADAPTIVE" - character(NAMELEN) :: encounter_check_plpl = "ADAPTIVE" !! Method used to compute pl-pl encounter checks. Options are "TRIANGULAR", "SORTSWEEP", or "ADAPTIVE" - character(NAMELEN) :: encounter_check_pltp = "ADAPTIVE" !! Method used to compute pl-tp encounter checks. Options are "TRIANGULAR", "SORTSWEEP", or "ADAPTIVE" - - ! The following are used internally, and are not set by the user, but instead are determined by the input value of INTERACTION_LOOPS - logical :: lflatten_interactions = .false. !! Use the flattened upper triangular matrix for pl-pl interaction loops - logical :: ladaptive_interactions = .false. !! Adaptive interaction loop is turned on (choose between TRIANGULAR and FLAT based on periodic timing tests) - logical :: lencounter_sas_plpl = .false. !! Use the Sort and Sweep algorithm to prune the encounter list before checking for close encounters - logical :: lencounter_sas_pltp = .false. !! Use the Sort and Sweep algorithm to prune the encounter list before checking for close encounters - logical :: ladaptive_encounters_plpl = .false. !! Adaptive encounter checking is turned on (choose between TRIANGULAR or SORTSWEEP based on periodic timing tests) - logical :: ladaptive_encounters_pltp = .false. !! Adaptive encounter checking is turned on (choose between TRIANGULAR or SORTSWEEP based on periodic timing tests) - - ! Logical flags to turn on or off various features of the code - logical :: lrhill_present = .false. !! Hill radii are given as an input rather than calculated by the code (can be used to inflate close encounter regions manually) - logical :: lextra_force = .false. !! User defined force function turned on - logical :: lbig_discard = .false. !! Save big bodies on every discard - logical :: lclose = .false. !! Turn on close encounters - logical :: lenergy = .false. !! Track the total energy of the system - logical :: loblatecb = .false. !! Calculate acceleration from oblate central body (automatically turns true if nonzero J2 is input) - logical :: lrotation = .false. !! Include rotation states of big bodies - logical :: ltides = .false. !! Include tidal dissipation - - ! Initial values to pass to the energy report subroutine (usually only used in the case of a restart, otherwise these will be updated with initial conditions values) - real(DP) :: Eorbit_orig = 0.0_DP !! Initial orbital energy - real(DP) :: GMtot_orig = 0.0_DP !! Initial system mass - real(DP), dimension(NDIM) :: Ltot_orig = 0.0_DP !! Initial total angular momentum vector - real(DP), dimension(NDIM) :: Lorbit_orig = 0.0_DP !! Initial orbital angular momentum - real(DP), dimension(NDIM) :: Lspin_orig = 0.0_DP !! Initial spin angular momentum vector - real(DP), dimension(NDIM) :: Lescape = 0.0_DP !! Angular momentum of bodies that escaped the system (used for bookeeping) - real(DP) :: GMescape = 0.0_DP !! Mass of bodies that escaped the system (used for bookeeping) - real(DP) :: Ecollisions = 0.0_DP !! Energy lost from system due to collisions - real(DP) :: Euntracked = 0.0_DP !! Energy gained from system due to escaped bodies - logical :: lfirstenergy = .true. !! This is the first time computing energe - logical :: lfirstkick = .true. !! Initiate the first kick in a symplectic step - logical :: lrestart = .false. !! Indicates whether or not this is a restarted run - - character(len=:), allocatable :: display_style !! Style of the output display {"STANDARD", "COMPACT"}). Default is "STANDARD" - integer(I4B) :: display_unit !! File unit number for display (either to stdout or to a log file) - logical :: log_output = .false. !! Logs the output to file instead of displaying it on the terminal - - ! Future features not implemented or in development - logical :: lgr = .false. !! Turn on GR - logical :: lyarkovsky = .false. !! Turn on Yarkovsky effect - logical :: lyorp = .false. !! Turn on YORP effect - type(swiftest_storage(nframes=:)), allocatable :: system_history - contains - procedure :: reader => io_param_reader - procedure :: writer => io_param_writer - procedure :: dump => io_dump_param - procedure :: read_in => io_read_in_param - procedure :: set_display => io_set_display_param - end type swiftest_parameters - - - !******************************************************************************************************************************** - ! swiftest_swiftest_particle_info class definitions and method interfaces - !******************************************************************************************************************************* - !> Class definition for the particle origin information object. This object is used to track time, location, and collisional regime - !> of fragments produced in collisional events. - type :: swiftest_particle_info - character(len=NAMELEN) :: name !! Non-unique name - character(len=NAMELEN) :: particle_type !! String containing a description of the particle type (e.g. Central Body, Massive Body, Test Particle) - character(len=NAMELEN) :: origin_type !! String containing a description of the origin of the particle (e.g. Initial Conditions, Supercatastrophic, Disruption, etc.) - real(DP) :: origin_time !! The time of the particle's formation - integer(I4B) :: collision_id !! The ID of the collision that formed the particle - real(DP), dimension(NDIM) :: origin_rh !! The heliocentric distance vector at the time of the particle's formation - real(DP), dimension(NDIM) :: origin_vh !! The heliocentric velocity vector at the time of the particle's formation - real(DP) :: discard_time !! The time of the particle's discard - character(len=NAMELEN) :: status !! Particle status description: Active, Merged, Fragmented, etc. - real(DP), dimension(NDIM) :: discard_rh !! The heliocentric distance vector at the time of the particle's discard - real(DP), dimension(NDIM) :: discard_vh !! The heliocentric velocity vector at the time of the particle's discard - integer(I4B) :: discard_body_id !! The id of the other body involved in the discard (0 if no other body involved) - contains - procedure :: copy => util_copy_particle_info !! Copies one set of information object components into another, component-by-component - procedure :: set_value => util_set_particle_info !! Sets one or more values of the particle information metadata object - end type swiftest_particle_info - - !******************************************************************************************************************************** - ! swiftest_base class definitions and methods - !******************************************************************************************************************************** - type, abstract :: swiftest_base - !! An abstract superclass for a generic Swiftest object - contains - !! The minimal methods that all systems must have - procedure :: read_in => io_read_in_base !! Read in body initial conditions from a file - procedure :: write_frame => netcdf_write_frame_base !! I/O routine for writing out a single frame of time-series data for all bodies in the system in NetCDF format - procedure :: write_info => netcdf_write_info_base !! Dump contents of particle information metadata to file - end type swiftest_base - - !******************************************************************************************************************************** - ! swiftest_cb class definitions and methods - !******************************************************************************************************************************** - !> An abstract class for a generic central body in a Swiftest simulation - type, abstract, extends(swiftest_base) :: swiftest_cb - type(swiftest_particle_info) :: info !! Particle metadata information - integer(I4B) :: id = 0 !! External identifier (unique) - real(DP) :: mass = 0.0_DP !! Central body mass (units MU) - real(DP) :: Gmass = 0.0_DP !! Central mass gravitational term G * mass (units GU * MU) - real(DP) :: radius = 0.0_DP !! Central body radius (units DU) - real(DP) :: density = 1.0_DP !! Central body mass density - calculated internally (units MU / DU**3) - real(DP) :: j2rp2 = 0.0_DP !! J2*R^2 term for central body - real(DP) :: j4rp4 = 0.0_DP !! J4*R^2 term for central body - real(DP), dimension(NDIM) :: aobl = 0.0_DP !! Barycentric acceleration due to central body oblatenes - real(DP), dimension(NDIM) :: atide = 0.0_DP !! Barycentric acceleration due to central body oblatenes - real(DP), dimension(NDIM) :: aoblbeg = 0.0_DP !! Barycentric acceleration due to central body oblatenes at beginning of step - real(DP), dimension(NDIM) :: aoblend = 0.0_DP !! Barycentric acceleration due to central body oblatenes at end of step - real(DP), dimension(NDIM) :: atidebeg = 0.0_DP !! Barycentric acceleration due to central body oblatenes at beginning of step - real(DP), dimension(NDIM) :: atideend = 0.0_DP !! Barycentric acceleration due to central body oblatenes at end of step - real(DP), dimension(NDIM) :: rb = 0.0_DP !! Barycentric position (units DU) - real(DP), dimension(NDIM) :: vb = 0.0_DP !! Barycentric velocity (units DU / TU) - real(DP), dimension(NDIM) :: agr = 0.0_DP !! Acceleration due to post-Newtonian correction - real(DP), dimension(NDIM) :: Ip = 0.0_DP !! Unitless principal moments of inertia (I1, I2, I3) / (MR**2). Principal axis rotation assumed. - real(DP), dimension(NDIM) :: rot = 0.0_DP !! Body rotation vector in inertial coordinate frame (units rad / TU) - real(DP) :: k2 = 0.0_DP !! Tidal Love number - real(DP) :: Q = 0.0_DP !! Tidal quality factor - real(DP) :: tlag = 0.0_DP !! Tidal phase lag angle - real(DP), dimension(NDIM) :: L0 = 0.0_DP !! Initial angular momentum of the central body - real(DP), dimension(NDIM) :: dL = 0.0_DP !! Change in angular momentum of the central body - contains - end type swiftest_cb - - !******************************************************************************************************************************** - ! swiftest_body definitions and methods - !******************************************************************************************************************************** - !> An abstract class for a generic collection of Swiftest bodies - type, abstract, extends(swiftest_base) :: swiftest_body - !! Superclass that defines the generic elements of a Swiftest particle - logical :: lfirst = .true. !! Run the current step as a first - integer(I4B) :: nbody = 0 !! Number of bodies - type(swiftest_particle_info), dimension(:), allocatable :: info !! Particle metadata information - integer(I4B), dimension(:), allocatable :: id !! External identifier (unique) - integer(I4B), dimension(:), allocatable :: status !! An integrator-specific status indicator - logical, dimension(:), allocatable :: ldiscard !! Body should be discarded - logical, dimension(:), allocatable :: lmask !! Logical mask used to select a subset of bodies when performing certain operations (drift, kick, accel, etc.) - real(DP), dimension(:), allocatable :: mu !! G * (Mcb + [m]) - real(DP), dimension(:,:), allocatable :: rh !! Heliocentric position - real(DP), dimension(:,:), allocatable :: vh !! Heliocentric velocity - real(DP), dimension(:,:), allocatable :: rb !! Barycentric position - real(DP), dimension(:,:), allocatable :: vb !! Barycentric velocity - real(DP), dimension(:,:), allocatable :: ah !! Total heliocentric acceleration - real(DP), dimension(:,:), allocatable :: aobl !! Barycentric accelerations of bodies due to central body oblatenes - real(DP), dimension(:,:), allocatable :: atide !! Tanngential component of acceleration of bodies due to tides - real(DP), dimension(:,:), allocatable :: agr !! Acceleration due to post-Newtonian correction - real(DP), dimension(:), allocatable :: ir3h !! Inverse heliocentric radius term (1/rh**3) - real(DP), dimension(:), allocatable :: a !! Semimajor axis (pericentric distance for a parabolic orbit) - real(DP), dimension(:), allocatable :: e !! Eccentricity - real(DP), dimension(:), allocatable :: inc !! Inclination - real(DP), dimension(:), allocatable :: capom !! Longitude of ascending node - real(DP), dimension(:), allocatable :: omega !! Argument of pericenter - real(DP), dimension(:), allocatable :: capm !! Mean anomaly - !! Note to developers: If you add components to this class, be sure to update methods and subroutines that traverse the - !! component list, such as setup_body and util_spill - contains - procedure(abstract_discard_body), deferred :: discard - procedure(abstract_kick_body), deferred :: kick - procedure(abstract_set_mu), deferred :: set_mu - procedure(abstract_step_body), deferred :: step - procedure(abstract_accel), deferred :: accel - ! These are concrete because the implementation is the same for all types of particles - procedure :: drift => drift_body !! Loop through bodies and call Danby drift routine on heliocentric variables - procedure :: v2pv => gr_vh2pv_body !! Converts from velocity to psudeovelocity for GR calculations using symplectic integrators - procedure :: pv2v => gr_pv2vh_body !! Converts from psudeovelocity to velocity for GR calculations using symplectic integrators - procedure :: read_frame_bin => io_read_frame_body !! I/O routine for writing out a single frame of time-series data for the central body - procedure :: accel_obl => obl_acc_body !! Compute the barycentric accelerations of bodies due to the oblateness of the central body - procedure :: el2xv => orbel_el2xv_vec !! Convert orbital elements to position and velocity vectors - procedure :: xv2el => orbel_xv2el_vec !! Convert position and velocity vectors to orbital elements - procedure :: setup => setup_body !! A constructor that sets the number of bodies and allocates all allocatable arrays - procedure :: accel_user => user_kick_getacch_body !! Add user-supplied heliocentric accelerations to planets - procedure :: append => util_append_body !! Appends elements from one structure to another - procedure :: dealloc => util_dealloc_body !! Deallocates all allocatable arrays - procedure :: fill => util_fill_body !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) - procedure :: resize => util_resize_body !! Checks the current size of a Swiftest body against the requested size and resizes it if it is too small. - procedure :: set_ir3 => util_set_ir3h !! Sets the inverse heliocentric radius term (1/rh**3) - procedure :: sort => util_sort_body !! Sorts body arrays by a sortable componen - procedure :: rearrange => util_sort_rearrange_body !! Rearranges the order of array elements of body based on an input index array. Used in sorting methods - procedure :: spill => util_spill_body !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) - generic :: read_frame => read_frame_bin !! Add the generic read frame for Fortran binary files - end type swiftest_body - - !******************************************************************************************************************************** - ! swiftest_pl definitions and methods - !******************************************************************************************************************************** - !> An abstract class for a generic collection of Swiftest massive bodies - type, abstract, extends(swiftest_body) :: swiftest_pl - !! Superclass that defines the generic elements of a Swiftest particle - real(DP), dimension(:), allocatable :: mass !! Body mass (units MU) - real(DP), dimension(:), allocatable :: Gmass !! Mass gravitational term G * mass (units GU * MU) - real(DP), dimension(:), allocatable :: rhill !! Body mass (units MU) - real(DP), dimension(:), allocatable :: renc !! Critical radius for close encounters - real(DP), dimension(:), allocatable :: radius !! Body radius (units DU) - real(DP), dimension(:,:), allocatable :: rbeg !! Position at beginning of step - real(DP), dimension(:,:), allocatable :: xend !! Position at end of step - real(DP), dimension(:,:), allocatable :: vbeg !! Velocity at beginning of step - real(DP), dimension(:), allocatable :: density !! Body mass density - calculated internally (units MU / DU**3) - real(DP), dimension(:,:), allocatable :: Ip !! Unitless principal moments of inertia (I1, I2, I3) / (MR**2). Principal axis rotation assumed. - real(DP), dimension(:,:), allocatable :: rot !! Body rotation vector in inertial coordinate frame (units rad / TU) - real(DP), dimension(:), allocatable :: k2 !! Tidal Love number - real(DP), dimension(:), allocatable :: Q !! Tidal quality factor - real(DP), dimension(:), allocatable :: tlag !! Tidal phase lag - integer(I4B), dimension(:,:), allocatable :: k_plpl !! Index array used to convert flattened the body-body comparison upper triangular matrix - integer(I8B) :: nplpl !! Number of body-body comparisons in the flattened upper triangular matrix - !! Note to developers: If you add components to this class, be sure to update methods and subroutines that traverse the - !! component list, such as setup_pl and util_spill_pl - contains - ! Massive body-specific concrete methods - ! These are concrete because they are the same implemenation for all integrators - procedure :: discard => discard_pl !! Placeholder method for discarding massive bodies - procedure :: flatten => util_flatten_eucl_plpl !! Sets up the (i, j) -> k indexing used for the single-loop blocking Euclidean distance matrix - procedure :: accel_int => kick_getacch_int_pl !! Compute direct cross (third) term heliocentric accelerations of massive bodies - procedure :: accel_obl => obl_acc_pl !! Compute the barycentric accelerations of bodies due to the oblateness of the central body - procedure :: setup => setup_pl !! A base constructor that sets the number of bodies and allocates and initializes all arrays - ! procedure :: accel_tides => tides_kick_getacch_pl !! Compute the accelerations of bodies due to tidal interactions with the central body - procedure :: append => util_append_pl !! Appends elements from one structure to another - procedure :: h2b => util_coord_h2b_pl !! Convert massive bodies from heliocentric to barycentric coordinates (position and velocity) - procedure :: b2h => util_coord_b2h_pl !! Convert massive bodies from barycentric to heliocentric coordinates (position and velocity) - procedure :: vh2vb => util_coord_vh2vb_pl !! Convert massive bodies from heliocentric to barycentric coordinates (velocity only) - procedure :: vb2vh => util_coord_vb2vh_pl !! Convert massive bodies from barycentric to heliocentric coordinates (velocity only) - procedure :: rh2rb => util_coord_rh2rb_pl !! Convert massive bodies from heliocentric to barycentric coordinates (position only) - procedure :: dealloc => util_dealloc_pl !! Deallocates all allocatable arrays - procedure :: fill => util_fill_pl !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) - procedure :: resize => util_resize_pl !! Checks the current size of a Swiftest body against the requested size and resizes it if it is too small. - procedure :: set_beg_end => util_set_beg_end_pl !! Sets the beginning and ending positions and velocities of planets. - procedure :: set_mu => util_set_mu_pl !! Method used to construct the vectorized form of the central body mass - procedure :: set_rhill => util_set_rhill !! Calculates the Hill's radii for each body - procedure :: set_renc_I4B => util_set_renc_I4B !! Sets the critical radius for encounter given an inpput integer scale factor - procedure :: set_renc_DP => util_set_renc_DP !! Sets the critical radius for encounter given an input real scale factor - generic :: set_renc => set_renc_I4B, set_renc_DP - procedure :: sort => util_sort_pl !! Sorts body arrays by a sortable component - procedure :: rearrange => util_sort_rearrange_pl !! Rearranges the order of array elements of body based on an input index array. Used in sorting methods - procedure :: spill => util_spill_pl !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) - end type swiftest_pl - - !******************************************************************************************************************************** - ! swiftest_tp definitions and methods - !******************************************************************************************************************************** - !> An abstract class for a generic collection of Swiftest test particles - type, abstract, extends(swiftest_body) :: swiftest_tp - !! Superclass that defines the generic elements of a Swiftest test particle - integer(I4B), dimension(:), allocatable :: isperi !! Perihelion passage flag - real(DP), dimension(:), allocatable :: peri !! Perihelion distance - real(DP), dimension(:), allocatable :: atp !! Semimajor axis following perihelion passage - integer(I4B), dimension(:,:), allocatable :: k_pltp !! Index array used to convert flattened the body-body comparison upper triangular matrix - integer(I8B) :: npltp !! Number of pl-tp comparisons in the flattened upper triangular matrix - !! Note to developers: If you add components to this class, be sure to update methods and subroutines that traverse the - !! component list, such as setup_tp and util_spill_tp - contains - ! Test particle-specific concrete methods - ! These are concrete because they are the same implemenation for all integrators - procedure :: discard => discard_tp !! Check to see if test particles should be discarded based on their positions relative to the massive bodies - procedure :: accel_int => kick_getacch_int_tp !! Compute direct cross (third) term heliocentric accelerations of test particles by massive bodies - procedure :: accel_obl => obl_acc_tp !! Compute the barycentric accelerations of bodies due to the oblateness of the central body - procedure :: setup => setup_tp !! A base constructor that sets the number of bodies and - procedure :: append => util_append_tp !! Appends elements from one structure to another - procedure :: h2b => util_coord_h2b_tp !! Convert test particles from heliocentric to barycentric coordinates (position and velocity) - procedure :: b2h => util_coord_b2h_tp !! Convert test particles from barycentric to heliocentric coordinates (position and velocity) - procedure :: vb2vh => util_coord_vb2vh_tp !! Convert test particles from barycentric to heliocentric coordinates (velocity only) - procedure :: vh2vb => util_coord_vh2vb_tp !! Convert test particles from heliocentric to barycentric coordinates (velocity only) - procedure :: rh2rb => util_coord_rh2rb_tp !! Convert test particles from heliocentric to barycentric coordinates (position only) - procedure :: dealloc => util_dealloc_tp !! Deallocates all allocatable arrays - procedure :: fill => util_fill_tp !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) - procedure :: get_peri => util_peri_tp !! Determine system pericenter passages for test particles - procedure :: resize => util_resize_tp !! Checks the current size of a Swiftest body against the requested size and resizes it if it is too small. - procedure :: set_mu => util_set_mu_tp !! Method used to construct the vectorized form of the central body mass - procedure :: sort => util_sort_tp !! Sorts body arrays by a sortable component - procedure :: rearrange => util_sort_rearrange_tp !! Rearranges the order of array elements of body based on an input index array. Used in sorting methods - procedure :: spill => util_spill_tp !! "Spills" bodies from one object to another depending on the results of a mask (uses the PACK intrinsic) - end type swiftest_tp - - !******************************************************************************************************************************** - ! swiftest_nbody_system class definitions and methods - !******************************************************************************************************************************** - !> An abstract class for a basic Swiftest nbody system - type, abstract :: swiftest_nbody_system - !! This superclass contains a minimial system of a set of test particles (tp), massive bodies (pl), and a central body (cb) - class(swiftest_cb), allocatable :: cb !! Central body data structure - class(swiftest_pl), allocatable :: pl !! Massive body data structure - class(swiftest_tp), allocatable :: tp !! Test particle data structure - class(swiftest_tp), allocatable :: tp_discards !! Discarded test particle data structure - class(swiftest_pl), allocatable :: pl_discards !! Discarded massive body particle data structure - real(DP) :: t = -1.0_DP !! Integration current time - real(DP) :: GMtot = 0.0_DP !! Total system mass - used for barycentric coordinate conversion - real(DP) :: ke_orbit = 0.0_DP !! System orbital kinetic energy - real(DP) :: ke_spin = 0.0_DP !! System spin kinetic energy - real(DP) :: pe = 0.0_DP !! System potential energy - real(DP) :: te = 0.0_DP !! System total energy - real(DP) :: oblpot = 0.0_DP !! System potential energy due to oblateness of the central body - real(DP), dimension(NDIM) :: Lorbit = 0.0_DP !! System orbital angular momentum vector - real(DP), dimension(NDIM) :: Lspin = 0.0_DP !! System spin angular momentum vector - real(DP), dimension(NDIM) :: Ltot = 0.0_DP !! System angular momentum vector - real(DP) :: ke_orbit_orig = 0.0_DP !! Initial orbital kinetic energy - real(DP) :: ke_spin_orig = 0.0_DP !! Initial spin kinetic energy - real(DP) :: pe_orig = 0.0_DP !! Initial potential energy - real(DP) :: Eorbit_orig = 0.0_DP !! Initial orbital energy - real(DP) :: GMtot_orig = 0.0_DP !! Initial system mass - real(DP), dimension(NDIM) :: Ltot_orig = 0.0_DP !! Initial total angular momentum vector - real(DP), dimension(NDIM) :: Lorbit_orig = 0.0_DP !! Initial orbital angular momentum - real(DP), dimension(NDIM) :: Lspin_orig = 0.0_DP !! Initial spin angular momentum vector - real(DP), dimension(NDIM) :: Lescape = 0.0_DP !! Angular momentum of bodies that escaped the system (used for bookeeping) - real(DP) :: GMescape = 0.0_DP !! Mass of bodies that escaped the system (used for bookeeping) - real(DP) :: Ecollisions = 0.0_DP !! Energy lost from system due to collisions - real(DP) :: Euntracked = 0.0_DP !! Energy gained from system due to escaped bodies - - ! Energy, momentum, and mass errors (used in error reporting) - real(DP) :: ke_orbit_error = 0.0_DP - real(DP) :: ke_spin_error = 0.0_DP - real(DP) :: pe_error = 0.0_DP - real(DP) :: Eorbit_error = 0.0_DP - real(DP) :: Ecoll_error = 0.0_DP - real(DP) :: Euntracked_error = 0.0_DP - real(DP) :: Etot_error = 0.0_DP - real(DP) :: Lorbit_error = 0.0_DP - real(DP) :: Lspin_error = 0.0_DP - real(DP) :: Lescape_error = 0.0_DP - real(DP) :: Ltot_error = 0.0_DP - real(DP) :: Mtot_error = 0.0_DP - real(DP) :: Mescape_error = 0.0_DP - - logical :: lbeg !! True if this is the beginning of a step. This is used so that test particle steps can be calculated - !! separately from massive bodies. Massive body variables are saved at half steps, and passed to - !! the test particles - contains - !> Each integrator will have its own version of the step - procedure(abstract_step_system), deferred :: step - - ! Concrete classes that are common to the basic integrator (only test particles considered for discard) - procedure :: discard => discard_system !! Perform a discard step on the system - procedure :: compact_output => io_compact_output !! Prints out out terminal output when display_style is set to COMPACT - procedure :: conservation_report => io_conservation_report !! Compute energy and momentum and print out the change with time - procedure :: dump => io_dump_system !! Dump the state of the system to a file - procedure :: get_old_t_final => netcdf_get_old_t_final_system !! Validates the dump file to check whether the dump file initial conditions duplicate the last frame of the netcdf output. - procedure :: read_frame => netcdf_read_frame_system !! Read in a frame of input data from file - procedure :: write_frame_netcdf => netcdf_write_frame_system !! Write a frame of input data from file - procedure :: write_frame_system => io_write_frame_system !! Write a frame of input data from file - procedure :: read_hdr => netcdf_read_hdr_system !! Read a header for an output frame in NetCDF format - procedure :: write_hdr => netcdf_write_hdr_system !! Write a header for an output frame in NetCDF format - procedure :: read_in => io_read_in_system !! Reads the initial conditions for an nbody system - procedure :: read_particle_info => netcdf_read_particle_info_system !! Read in particle metadata from file - procedure :: obl_pot => obl_pot_system !! Compute the contribution to the total gravitational potential due solely to the oblateness of the central body - procedure :: initialize => setup_initialize_system !! Initialize the system from input files - procedure :: init_particle_info => setup_initialize_particle_info_system !! Initialize the system from input files - ! procedure :: step_spin => tides_step_spin_system !! Steps the spins of the massive & central bodies due to tides. - procedure :: set_msys => util_set_msys !! Sets the value of msys from the masses of system bodies. - procedure :: get_energy_and_momentum => util_get_energy_momentum_system !! Calculates the total system energy and momentum - procedure :: get_idvals => util_get_idvalues_system !! Returns an array of all id values in use in the system - procedure :: rescale => util_rescale_system !! Rescales the system into a new set of units - procedure :: validate_ids => util_valid_id_system !! Validate the numerical ids passed to the system and save the maximum value - generic :: write_frame => write_frame_system, write_frame_netcdf !! Generic method call for reading a frame of output data - end type swiftest_nbody_system - - - abstract interface - subroutine abstract_accel(self, system, param, t, lbeg) - import swiftest_body, swiftest_nbody_system, swiftest_parameters, DP - class(swiftest_body), intent(inout) :: self !! Swiftest body data structure - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - real(DP), intent(in) :: t !! Current simulation time - logical, intent(in) :: lbeg !! Optional argument that determines whether or not this is the beginning or end of the step - end subroutine abstract_accel - - subroutine abstract_discard_body(self, system, param) - import swiftest_body, swiftest_nbody_system, swiftest_parameters - class(swiftest_body), intent(inout) :: self !! Swiftest body object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine abstract_discard_body - - subroutine abstract_kick_body(self, system, param, t, dt, lbeg) - import swiftest_body, swiftest_nbody_system, swiftest_parameters, DP - implicit none - class(swiftest_body), intent(inout) :: self !! Swiftest generic body object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system objec - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - real(DP), intent(in) :: t !! Current time - real(DP), intent(in) :: dt !! Stepsize - logical, intent(in) :: lbeg !! Logical flag indicating whether this is the beginning of the half step or not. - end subroutine abstract_kick_body - - subroutine abstract_set_mu(self, cb) - import swiftest_body, swiftest_cb - class(swiftest_body), intent(inout) :: self !! Swiftest body object - class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object - end subroutine abstract_set_mu - - subroutine abstract_step_body(self, system, param, t, dt) - import DP, swiftest_body, swiftest_nbody_system, swiftest_parameters - implicit none - class(swiftest_body), intent(inout) :: self !! Swiftest body object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - real(DP), intent(in) :: t !! Simulation time - real(DP), intent(in) :: dt !! Current stepsize - end subroutine abstract_step_body - - subroutine abstract_step_system(self, param, t, dt) - import DP, swiftest_nbody_system, swiftest_parameters - implicit none - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - real(DP), intent(in) :: t !! Simulation time - real(DP), intent(in) :: dt !! Current stepsize - end subroutine abstract_step_system - end interface - - interface - module subroutine check(status, call_identifier) - implicit none - integer, intent (in) :: status !! The status code returned by a NetCDF function - character(len=*), intent(in), optional :: call_identifier - end subroutine check - - module subroutine discard_pl(self, system, param) - implicit none - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameter - end subroutine discard_pl - - module subroutine discard_system(self, param) - implicit none - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine discard_system - - module subroutine discard_tp(self, system, param) - implicit none - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine discard_tp - - module subroutine drift_all(mu, x, v, n, param, dt, lmask, iflag) - implicit none - real(DP), dimension(:), intent(in) :: mu !! Vector of gravitational constants - real(DP), dimension(:,:), intent(inout) :: x, v !! Position and velocity vectors - integer(I4B), intent(in) :: n !! number of bodies - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - real(DP), intent(in) :: dt !! Stepsize - logical, dimension(:), intent(in) :: lmask !! Logical mask of size self%nbody that determines which bodies to drift. - integer(I4B), dimension(:), intent(out) :: iflag !! Vector of error flags. 0 means no problem - end subroutine drift_all - - module subroutine drift_body(self, system, param, dt) - implicit none - class(swiftest_body), intent(inout) :: self !! Swiftest particle data structure - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - real(DP), intent(in) :: dt !! Stepsize - end subroutine drift_body - - pure elemental module subroutine drift_one(mu, px, py, pz, vx, vy, vz, dt, iflag) - !$omp declare simd(drift_one) - implicit none - real(DP), intent(in) :: mu !! G * (Mcb + m), G = gravitational constant, Mcb = mass of central body, m = mass of body to drift - real(DP), intent(inout) :: px, py, pz, vx, vy, vz !! Position and velocity of body to drift - real(DP), intent(in) :: dt !! Step size - integer(I4B), intent(out) :: iflag !! iflag : error status flag for Danby drift (0 = OK, nonzero = ERROR) - end subroutine drift_one - - pure module subroutine gr_kick_getaccb_ns_body(self, system, param) - implicit none - class(swiftest_body), intent(inout) :: self !! Swiftest generic body object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - end subroutine gr_kick_getaccb_ns_body - - pure module subroutine gr_kick_getacch(mu, x, lmask, n, inv_c2, agr) - implicit none - real(DP), dimension(:), intent(in) :: mu !! Gravitational constant - real(DP), dimension(:,:), intent(in) :: x !! Position vectors - logical, dimension(:), intent(in) :: lmask !! Logical mask indicating which bodies to compute - integer(I4B), intent(in) :: n !! Total number of bodies - real(DP), intent(in) :: inv_c2 !! Inverse speed of light squared: 1 / c**2 - real(DP), dimension(:,:), intent(out) :: agr !! Accelerations - end subroutine gr_kick_getacch - - pure module subroutine gr_p4_pos_kick(param, x, v, dt) - implicit none - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - real(DP), dimension(:), intent(inout) :: x !! Position vector - real(DP), dimension(:), intent(in) :: v !! Velocity vector - real(DP), intent(in) :: dt !! Step size - end subroutine gr_p4_pos_kick - - pure module subroutine gr_pseudovel2vel(param, mu, rh, pv, vh) - implicit none - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - real(DP), intent(in) :: mu !! G * (Mcb + m), G = gravitational constant, Mcb = mass of central body, m = mass of body - real(DP), dimension(:), intent(in) :: rh !! Swiftestcentric position vector - real(DP), dimension(:), intent(in) :: pv !! Pseudovelocity velocity vector - see Saha & Tremain (1994), eq. (32) - real(DP), dimension(:), intent(out) :: vh !! Swiftestcentric velocity vector - end subroutine gr_pseudovel2vel - - pure module subroutine gr_pv2vh_body(self, param) - implicit none - class(swiftest_body), intent(inout) :: self !! Swiftest particle object - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - end subroutine gr_pv2vh_body - - pure module subroutine gr_vel2pseudovel(param, mu, rh, vh, pv) - implicit none - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - real(DP), intent(in) :: mu !! G * (Mcb + m), G = gravitational constant, Mcb = mass of central body, m = mass of body - real(DP), dimension(:), intent(in) :: rh !! Swiftestcentric position vector - real(DP), dimension(:), intent(in) :: vh !! Swiftestcentric velocity vector - real(DP), dimension(:), intent(out) :: pv !! Pseudovelocity vector - see Saha & Tremain (1994), eq. (32) - end subroutine gr_vel2pseudovel - - pure module subroutine gr_vh2pv_body(self, param) - implicit none - class(swiftest_body), intent(inout) :: self !! Swiftest particle object - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - end subroutine gr_vh2pv_body - - module subroutine io_compact_output(self, param, timer) - implicit none - class(swiftest_nbody_system), intent(in) :: self !! Swiftest nbody system object - class(swiftest_parameters), intent(in) :: param !! Input colleciton of user-defined parameters - class(*), intent(in) :: timer !! Object used for computing elapsed wall time - end subroutine io_compact_output - - module subroutine io_conservation_report(self, param, lterminal) - implicit none - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object - class(swiftest_parameters), intent(inout) :: param !! Input colleciton of user-defined parameters - logical, intent(in) :: lterminal !! Indicates whether to output information to the terminal screen - end subroutine io_conservation_report - - module subroutine io_dump_param(self, param_file_name) - implicit none - class(swiftest_parameters),intent(in) :: self !! Output collection of parameters - character(len=*), intent(in) :: param_file_name !! Parameter input file name (i.e. param.in) - end subroutine io_dump_param - - module subroutine io_dump_system(self, param) - implicit none - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine io_dump_system - - module subroutine io_dump_storage(self, param) - implicit none - class(swiftest_storage(*)), intent(inout) :: self !! Swiftest simulation history storage object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine io_dump_storage - - module subroutine io_get_args(integrator, param_file_name, display_style) - implicit none - character(len=:), allocatable, intent(inout) :: integrator !! Symbolic code of the requested integrator - character(len=:), allocatable, intent(inout) :: param_file_name !! Name of the input parameters file - character(len=:), allocatable, intent(inout) :: display_style !! Style of the output display {"STANDARD", "COMPACT"}). Default is "STANDARD" - end subroutine io_get_args - - module function io_get_token(buffer, ifirst, ilast, ierr) result(token) - implicit none - character(len=*), intent(in) :: buffer !! Input string buffer - integer(I4B), intent(inout) :: ifirst !! Index of the buffer at which to start the search for a token - integer(I4B), intent(out) :: ilast !! Index of the buffer at the end of the returned token - integer(I4B), intent(out) :: ierr !! Error code - character(len=:), allocatable :: token !! Returned token string - end function io_get_token - - module subroutine io_log_one_message(file, message) - implicit none - character(len=*), intent(in) :: file !! Name of file to log - character(len=*), intent(in) :: message - end subroutine io_log_one_message - - module subroutine io_log_start(param, file, header) - implicit none - class(swiftest_parameters), intent(in) :: param !! Current Swiftest run configuration parameters - character(len=*), intent(in) :: file !! Name of file to log - character(len=*), intent(in) :: header !! Header to print at top of log file - end subroutine io_log_start - - module subroutine io_param_reader(self, unit, iotype, v_list, iostat, iomsg) - implicit none - class(swiftest_parameters), intent(inout) :: self !! Collection of parameters - integer(I4B), intent(in) :: unit !! File unit number - character(len=*), intent(in) :: iotype !! Dummy argument passed to the input/output procedure contains the text from the char-literal-constant, prefixed with DT. - !! If you do not include a char-literal-constant, the iotype argument contains only DT. - character(len=*), intent(in) :: v_list(:) !! The first element passes the integrator code to the reader - integer(I4B), intent(out) :: iostat !! IO status code - character(len=*), intent(inout) :: iomsg !! Message to pass if iostat /= 0 - end subroutine io_param_reader - - module subroutine io_param_writer(self, unit, iotype, v_list, iostat, iomsg) - implicit none - class(swiftest_parameters), intent(in) :: self !! Collection of parameters - integer(I4B), intent(in) :: unit !! File unit number - character(len=*), intent(in) :: iotype !! Dummy argument passed to the input/output procedure contains the text from the char-literal-constant, prefixed with DT. - !! If you do not include a char-literal-constant, the iotype argument contains only DT. - integer(I4B), intent(in) :: v_list(:) !! Not used in this procedure - integer(I4B), intent(out) :: iostat !! IO status code - character(len=*), intent(inout) :: iomsg !! Message to pass if iostat /= 0 - end subroutine io_param_writer - end interface - - interface io_param_writer_one - module subroutine io_param_writer_one_char(param_name, param_value, unit) - implicit none - character(len=*), intent(in) :: param_name !! Name of parameter to print - character(len=*), intent(in) :: param_value !! Value of parameter to print - integer(I4B), intent(in) :: unit !! Open file unit number to print parameter to - end subroutine io_param_writer_one_char - - module subroutine io_param_writer_one_DP(param_name, param_value, unit) - implicit none - character(len=*), intent(in) :: param_name !! Name of parameter to print - real(DP), intent(in) :: param_value !! Value of parameter to print - integer(I4B), intent(in) :: unit !! Open file unit number to print parameter to - end subroutine io_param_writer_one_DP - - module subroutine io_param_writer_one_DParr(param_name, param_value, unit) - implicit none - character(len=*), intent(in) :: param_name !! Name of parameter to print - real(DP), dimension(:), intent(in) :: param_value !! Value of parameter to print - integer(I4B), intent(in) :: unit !! Open file unit number to print parameter to - end subroutine io_param_writer_one_DParr - - module subroutine io_param_writer_one_I4B(param_name, param_value, unit) - implicit none - character(len=*), intent(in) :: param_name !! Name of parameter to print - integer(I4B), intent(in) :: param_value !! Value of parameter to print - integer(I4B), intent(in) :: unit !! Open file unit number to print parameter to - end subroutine io_param_writer_one_I4B - - module subroutine io_param_writer_one_I4Barr(param_name, param_value, unit) - implicit none - character(len=*), intent(in) :: param_name !! Name of parameter to print - integer(I4B), dimension(:), intent(in) :: param_value !! Value of parameter to print - integer(I4B), intent(in) :: unit !! Open file unit number to print parameter to - end subroutine io_param_writer_one_I4Barr - - module subroutine io_param_writer_one_I8B(param_name, param_value, unit) - implicit none - character(len=*), intent(in) :: param_name !! Name of parameter to print - integer(I8B), intent(in) :: param_value !! Value of parameter to print - integer(I4B), intent(in) :: unit !! Open file unit number to print parameter to - end subroutine io_param_writer_one_I8B - - module subroutine io_param_writer_one_logical(param_name, param_value, unit) - implicit none - character(len=*), intent(in) :: param_name !! Name of parameter to print - logical, intent(in) :: param_value !! Value of parameter to print - integer(I4B), intent(in) :: unit !! Open file unit number to print parameter to - end subroutine io_param_writer_one_logical - - module subroutine io_param_writer_one_QP(param_name, param_value, unit) - implicit none - character(len=*), intent(in) :: param_name !! Name of parameter to print - real(QP), intent(in) :: param_value !! Value of parameter to print - integer(I4B), intent(in) :: unit !! Open file unit number to print parameter to - end subroutine io_param_writer_one_QP - end interface io_param_writer_one - - interface - - module subroutine io_read_in_base(self,param) - implicit none - class(swiftest_base), intent(inout) :: self !! Swiftest base object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine io_read_in_base - - module subroutine io_read_in_param(self, param_file_name) - implicit none - class(swiftest_parameters), intent(inout) :: self !! Current run configuration parameters - character(len=*), intent(in) :: param_file_name !! Parameter input file name (i.e. param.in) - end subroutine io_read_in_param - - module subroutine io_read_in_system(self, param) - implicit none - class(swiftest_nbody_system), intent(inout) :: self - class(swiftest_parameters), intent(inout) :: param - end subroutine io_read_in_system - - module function io_read_frame_body(self, iu, param) result(ierr) - implicit none - class(swiftest_body), intent(inout) :: self !! Swiftest body object - integer(I4B), intent(inout) :: iu !! Unit number for the output file to write frame to - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - integer(I4B) :: ierr !! Error code: returns 0 if the read is successful - end function io_read_frame_body - - module function io_read_frame_system(self, iu, param) result(ierr) - implicit none - class(swiftest_nbody_system),intent(inout) :: self !! Swiftest system object - integer(I4B), intent(inout) :: iu !! Unit number for the output file to read frame from - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - integer(I4B) :: ierr !! Error code: returns 0 if the read is successful - end function io_read_frame_system - - module subroutine io_set_display_param(self, display_style) - implicit none - class(swiftest_parameters), intent(inout) :: self !! Current run configuration parameters - character(*), intent(in) :: display_style !! Style of the output display - end subroutine io_set_display_param - - module subroutine io_toupper(string) - implicit none - character(*), intent(inout) :: string !! String to make upper case - end subroutine io_toupper - - module subroutine io_write_frame_system(self, param) - implicit none - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine io_write_frame_system - - module subroutine kick_getacch_int_pl(self, param) - implicit none - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_parameters), intent(inout) :: param !! Current swiftest run configuration parameters - end subroutine kick_getacch_int_pl - - module subroutine kick_getacch_int_tp(self, param, GMpl, rhp, npl) - implicit none - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - class(swiftest_parameters), intent(inout) :: param !! Current swiftest run configuration parameters - real(DP), dimension(:), intent(in) :: GMpl !! Massive body masses - real(DP), dimension(:,:), intent(in) :: rhp !! Massive body position vectors - integer(I4B), intent(in) :: npl !! Number of active massive bodies - end subroutine kick_getacch_int_tp - - module subroutine kick_getacch_int_all_flat_pl(npl, nplpl, k_plpl, x, Gmass, radius, acc) - implicit none - integer(I4B), intent(in) :: npl !! Number of massive bodies - integer(I8B), intent(in) :: nplpl !! Number of massive body interactions to compute - integer(I4B), dimension(:,:), intent(in) :: k_plpl !! Array of interaction pair indices (flattened upper triangular matrix) - real(DP), dimension(:,:), intent(in) :: x !! Position vector array - real(DP), dimension(:), intent(in) :: Gmass !! Array of massive body G*mass - real(DP), dimension(:), intent(in), optional :: radius !! Array of massive body radii - real(DP), dimension(:,:), intent(inout) :: acc !! Acceleration vector array - end subroutine kick_getacch_int_all_flat_pl - - module subroutine kick_getacch_int_all_triangular_pl(npl, nplm, x, Gmass, radius, acc) - implicit none - integer(I4B), intent(in) :: npl !! Total number of massive bodies - integer(I4B), intent(in) :: nplm !! Number of fully interacting massive bodies - real(DP), dimension(:,:), intent(in) :: x !! Position vector array - real(DP), dimension(:), intent(in) :: Gmass !! Array of massive body G*mass - real(DP), dimension(:), intent(in), optional :: radius !! Array of massive body radii - real(DP), dimension(:,:), intent(inout) :: acc !! Acceleration vector array - end subroutine kick_getacch_int_all_triangular_pl - - module subroutine kick_getacch_int_all_tp(ntp, npl, xtp, xpl, GMpl, lmask, acc) - implicit none - integer(I4B), intent(in) :: ntp !! Number of test particles - integer(I4B), intent(in) :: npl !! Number of massive bodies - real(DP), dimension(:,:), intent(in) :: xtp !! Test particle position vector array - real(DP), dimension(:,:), intent(in) :: xpl !! Massive body particle position vector array - real(DP), dimension(:), intent(in) :: GMpl !! Array of massive body G*mass - logical, dimension(:), intent(in) :: lmask !! Logical mask indicating which test particles should be computed - real(DP), dimension(:,:), intent(inout) :: acc !! Acceleration vector array - end subroutine kick_getacch_int_all_tp - - pure module subroutine kick_getacch_int_one_pl(rji2, xr, yr, zr, Gmi, Gmj, axi, ayi, azi, axj, ayj, azj) - !$omp declare simd(kick_getacch_int_one_pl) - implicit none - real(DP), intent(in) :: rji2 !! Square of distance between the two bodies - real(DP), intent(in) :: xr, yr, zr !! Distances between the two bodies in x, y, and z directions - real(DP), intent(in) :: Gmi !! G*mass of body i - real(DP), intent(in) :: Gmj !! G*mass of body j - real(DP), intent(inout) :: axi, ayi, azi !! Acceleration vector components of body i - real(DP), intent(inout) :: axj, ayj, azj !! Acceleration vector components of body j - end subroutine kick_getacch_int_one_pl - - pure module subroutine kick_getacch_int_one_tp(rji2, xr, yr, zr, Gmpl, ax, ay, az) - !$omp declare simd(kick_getacch_int_one_tp) - implicit none - real(DP), intent(in) :: rji2 !! Square of distance between the test particle and massive body - real(DP), intent(in) :: xr, yr, zr !! Distances between the two bodies in x, y, and z directions - real(DP), intent(in) :: Gmpl !! G*mass of massive body - real(DP), intent(inout) :: ax, ay, az !! Acceleration vector components of test particle - end subroutine kick_getacch_int_one_tp - - module subroutine netcdf_close(self) - implicit none - class(netcdf_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset - end subroutine netcdf_close - - module subroutine netcdf_flush(self, param) - implicit none - class(netcdf_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine netcdf_flush - - module function netcdf_get_old_t_final_system(self, param) result(old_t_final) - implicit none - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - real(DP) :: old_t_final !! Final time from last run - end function netcdf_get_old_t_final_system - - module subroutine netcdf_initialize_output(self, param) - implicit none - class(netcdf_parameters), intent(inout) :: self !! Parameters used to for writing a NetCDF dataset to file - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - end subroutine netcdf_initialize_output - - module subroutine netcdf_open(self, param, readonly) - implicit none - class(netcdf_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - logical, optional, intent(in) :: readonly !! Logical flag indicating that this should be open read only - end subroutine netcdf_open - - module subroutine netcdf_sync(self) - implicit none - class(netcdf_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset - end subroutine netcdf_sync - - module function netcdf_read_frame_system(self, nc, param) result(ierr) - implicit none - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest system object - class(netcdf_parameters), intent(inout) :: nc !! Parameters used to for reading a NetCDF dataset to file - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - integer(I4B) :: ierr !! Error code: returns 0 if the read is successful - end function netcdf_read_frame_system - - module subroutine netcdf_read_hdr_system(self, nc, param) - implicit none - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object - class(netcdf_parameters), intent(inout) :: nc !! Parameters used to for reading a NetCDF dataset to file - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine netcdf_read_hdr_system - - module subroutine netcdf_read_particle_info_system(self, nc, param, plmask, tpmask) - implicit none - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object - class(netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular NetCDF dataset - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - logical, dimension(:), intent(in) :: plmask !! Logical array indicating which index values belong to massive bodies - logical, dimension(:), intent(in) :: tpmask !! Logical array indicating which index values belong to test particles - end subroutine netcdf_read_particle_info_system - - module subroutine netcdf_write_frame_base(self, nc, param) - implicit none - class(swiftest_base), intent(in) :: self !! Swiftest base object - class(netcdf_parameters), intent(inout) :: nc !! Parameters used to for writing a NetCDF dataset to file - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine netcdf_write_frame_base - - module subroutine netcdf_write_frame_system(self, nc, param) - implicit none - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest system object - class(netcdf_parameters), intent(inout) :: nc !! Parameters used to for writing a NetCDF dataset to file - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine netcdf_write_frame_system - - module subroutine netcdf_write_hdr_system(self, nc, param) - implicit none - class(swiftest_nbody_system), intent(in) :: self !! Swiftest nbody system object - class(netcdf_parameters), intent(inout) :: nc !! Parameters used to for writing a NetCDF dataset to file - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine netcdf_write_hdr_system - - module subroutine netcdf_write_info_base(self, nc, param) - implicit none - class(swiftest_base), intent(in) :: self !! Swiftest particle object - class(netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular NetCDF dataset - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine netcdf_write_info_base - - module subroutine obl_acc_body(self, system) - implicit none - class(swiftest_body), intent(inout) :: self !! Swiftest body object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object - end subroutine obl_acc_body - - module subroutine obl_acc_pl(self, system) - implicit none - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object - end subroutine obl_acc_pl - - module subroutine obl_acc_tp(self, system) - implicit none - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object - end subroutine obl_acc_tp - - module subroutine obl_pot_system(self) - implicit none - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object - end subroutine obl_pot_system - - module subroutine orbel_el2xv_vec(self, cb) - implicit none - class(swiftest_body), intent(inout) :: self !! Swiftest body object - class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object - end subroutine orbel_el2xv_vec - - pure module subroutine orbel_scget(angle, sx, cx) - !$omp declare simd(orbel_scget) - implicit none - real(DP), intent(in) :: angle - real(DP), intent(out) :: sx, cx - end subroutine orbel_scget - - pure module subroutine orbel_xv2aeq(mu, px, py, pz, vx, vy, vz, a, e, q) - !$omp declare simd(orbel_xv2aeq) - implicit none - real(DP), intent(in) :: mu !! Gravitational constant - real(DP), intent(in) :: px,py,pz !! Position vector - real(DP), intent(in) :: vx,vy,vz !! Velocity vector - real(DP), intent(out) :: a !! semimajor axis - real(DP), intent(out) :: e !! eccentricity - real(DP), intent(out) :: q !! periapsis - end subroutine orbel_xv2aeq - - pure module subroutine orbel_xv2aqt(mu, px, py, pz, vx, vy, vz, a, q, capm, tperi) - !$omp declare simd(orbel_xv2aqt) - implicit none - real(DP), intent(in) :: mu !! Gravitational constant - real(DP), intent(in) :: px,py,pz !! Position vector - real(DP), intent(in) :: vx,vy,vz !! Velocity vector - real(DP), intent(out) :: a !! semimajor axis - real(DP), intent(out) :: q !! periapsis - real(DP), intent(out) :: capm !! mean anomaly - real(DP), intent(out) :: tperi !! time of pericenter passage - end subroutine orbel_xv2aqt - - pure module subroutine orbel_xv2el(mu, px, py, pz, vx, vy, vz, a, e, inc, capom, omega, capm, varpi, lam, f, cape, capf) - implicit none - real(DP), intent(in) :: mu !! Gravitational constant - real(DP), intent(in) :: px,py,pz !! Position vector - real(DP), intent(in) :: vx,vy,vz !! Velocity vector - real(DP), intent(out) :: a !! semimajor axis - real(DP), intent(out) :: e !! eccentricity - real(DP), intent(out) :: inc !! inclination - real(DP), intent(out) :: capom !! longitude of ascending node - real(DP), intent(out) :: omega !! argument of periapsis - real(DP), intent(out) :: capm !! mean anomaly - real(DP), intent(out) :: varpi !! longitude of periapsis - real(DP), intent(out) :: lam !! mean longitude - real(DP), intent(out) :: f !! true anomaly - real(DP), intent(out) :: cape !! eccentric anomaly (eccentric orbits) - real(DP), intent(out) :: capf !! hyperbolic anomaly (hyperbolic orbits) - end subroutine orbel_xv2el - - module subroutine orbel_xv2el_vec(self, cb) - implicit none - class(swiftest_body), intent(inout) :: self !! Swiftest body object - class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object - end subroutine orbel_xv2el_vec - - module subroutine setup_body(self, n, param) - implicit none - class(swiftest_body), intent(inout) :: self !! Swiftest body object - integer(I4B), intent(in) :: n !! Number of particles to allocate space for - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - end subroutine setup_body - - module subroutine setup_construct_system(system, param) - implicit none - class(swiftest_nbody_system), allocatable, intent(inout) :: system !! Swiftest system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine setup_construct_system - - module subroutine setup_initialize_particle_info_system(self, param) - implicit none - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine setup_initialize_particle_info_system - - module subroutine setup_initialize_system(self, param) - implicit none - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine setup_initialize_system - - module subroutine setup_pl(self, n, param) - implicit none - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - integer(I4B), intent(in) :: n !! Number of particles to allocate space for - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - end subroutine setup_pl - - module subroutine setup_tp(self, n, param) - implicit none - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - integer(I4B), intent(in) :: n !! Number of particles to allocate space for - class(swiftest_parameters), intent(in) :: param !! Current run configuration parametersr - end subroutine setup_tp - - ! TODO: Implement the tides model - module subroutine tides_kick_getacch_pl(self, system) - implicit none - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object - end subroutine tides_kick_getacch_pl - - module subroutine tides_step_spin_system(self, param, t, dt) - implicit none - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - real(DP), intent(in) :: t !! Simulation time - real(DP), intent(in) :: dt !! Current stepsize - end subroutine tides_step_spin_system - - module subroutine user_kick_getacch_body(self, system, param, t, lbeg) - implicit none - class(swiftest_body), intent(inout) :: self !! Swiftest massive body particle data structure - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody_system_object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - real(DP), intent(in) :: t !! Current time - logical, intent(in) :: lbeg !! Optional argument that determines whether or not this is the beginning or end of the step - end subroutine user_kick_getacch_body - end interface - - interface util_append - 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, 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, 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, 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_info(arr, source, nold, nsrc, lsource_mask) - implicit none - type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: arr !! Destination array - type(swiftest_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 util_append_arr_info - - 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 - - interface - 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 - logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to - end subroutine util_append_body - - module subroutine util_append_pl(self, source, lsource_mask) - implicit none - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - 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_pl - - module subroutine util_append_tp(self, source, lsource_mask) - implicit none - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - 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_tp - - module subroutine util_coord_b2h_pl(self, cb) - implicit none - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object - end subroutine util_coord_b2h_pl - - module subroutine util_coord_b2h_tp(self, cb) - implicit none - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - class(swiftest_cb), intent(in) :: cb !! Swiftest central body object - end subroutine util_coord_b2h_tp - - module subroutine util_coord_h2b_pl(self, cb) - implicit none - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object - end subroutine util_coord_h2b_pl - - module subroutine util_coord_h2b_tp(self, cb) - implicit none - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - class(swiftest_cb), intent(in) :: cb !! Swiftest central body object - end subroutine util_coord_h2b_tp - - module subroutine util_coord_vb2vh_pl(self, cb) - implicit none - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object - end subroutine util_coord_vb2vh_pl - - module subroutine util_coord_vb2vh_tp(self, vbcb) - implicit none - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - real(DP), dimension(:), intent(in) :: vbcb !! Barycentric velocity of the central body - end subroutine util_coord_vb2vh_tp - - module subroutine util_coord_vh2vb_pl(self, cb) - implicit none - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object - end subroutine util_coord_vh2vb_pl - - module subroutine util_coord_vh2vb_tp(self, vbcb) - implicit none - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - real(DP), dimension(:), intent(in) :: vbcb !! Barycentric velocity of the central body - end subroutine util_coord_vh2vb_tp - - module subroutine util_coord_rh2rb_pl(self, cb) - implicit none - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object - end subroutine util_coord_rh2rb_pl - - module subroutine util_coord_rh2rb_tp(self, cb) - implicit none - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - class(swiftest_cb), intent(in) :: cb !! Swiftest central body object - end subroutine util_coord_rh2rb_tp - - module subroutine util_copy_particle_info(self, source) - implicit none - class(swiftest_particle_info), intent(inout) :: self - class(swiftest_particle_info), intent(in) :: source - end subroutine util_copy_particle_info - - module subroutine util_copy_particle_info_arr(source, dest, idx) - implicit none - class(swiftest_particle_info), dimension(:), intent(in) :: source !! Source object to copy into - class(swiftest_particle_info), dimension(:), intent(inout) :: dest !! Swiftest body object with particle metadata information object - integer(I4B), dimension(:), intent(in), optional :: idx !! Optional array of indices to draw the source object - end subroutine util_copy_particle_info_arr - - module subroutine util_copy_store(self, source) - implicit none - class(swiftest_storage_frame), intent(inout) :: self !! Swiftest storage frame object - class(*), intent(in) :: source !! Any object that one wishes to store - end subroutine util_copy_store - - module subroutine util_dealloc_body(self) - implicit none - class(swiftest_body), intent(inout) :: self - end subroutine util_dealloc_body - - module subroutine util_dealloc_pl(self) - implicit none - class(swiftest_pl), intent(inout) :: self - end subroutine util_dealloc_pl - - module subroutine util_final_system(self) - implicit none - class(swiftest_nbody_system), intent(inout) :: self - end subroutine util_final_system - - module subroutine util_dealloc_tp(self) - implicit none - class(swiftest_tp), intent(inout) :: self - end subroutine util_dealloc_tp - - module subroutine util_exit(code) - implicit none - integer(I4B), intent(in) :: code !! Failure exit code - end subroutine util_exit - - module subroutine util_fill_body(self, inserts, lfill_list) - implicit none - class(swiftest_body), intent(inout) :: self !! Swiftest body object - class(swiftest_body), intent(in) :: inserts !! Swiftest body object to be inserted - logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - end subroutine util_fill_body - - module subroutine util_fill_pl(self, inserts, lfill_list) - implicit none - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_body), intent(in) :: inserts !! Swiftest body object to be inserted - logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - end subroutine util_fill_pl - - module subroutine util_fill_tp(self, inserts, lfill_list) - implicit none - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - class(swiftest_body), intent(in) :: inserts !! Swiftest body object to be inserted - logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - end subroutine util_fill_tp - end interface - - interface util_fill - module subroutine util_fill_arr_char_string(keeps, inserts, lfill_list) - implicit none - character(len=STRMAX), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - character(len=STRMAX), 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 util_fill_arr_char_string - - module subroutine util_fill_arr_DP(keeps, inserts, lfill_list) - implicit none - real(DP), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - real(DP), 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 util_fill_arr_DP - - module subroutine util_fill_arr_DPvec(keeps, inserts, lfill_list) - implicit none - real(DP), dimension(:,:), allocatable, intent(inout) :: keeps !! Array of values to keep - real(DP), 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 util_fill_arr_DPvec - - module subroutine util_fill_arr_I4B(keeps, inserts, lfill_list) - implicit none - integer(I4B), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - integer(I4B), 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 util_fill_arr_I4B - - module subroutine util_fill_arr_info(keeps, inserts, lfill_list) - implicit none - type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - type(swiftest_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 util_fill_arr_info - - module subroutine util_fill_arr_logical(keeps, inserts, lfill_list) - implicit none - logical, dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - logical, 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 util_fill_arr_logical - end interface - - interface - - module subroutine util_final_storage(self) - implicit none - type(swiftest_storage(*)) :: self - end subroutine util_final_storage - - module subroutine util_final_storage_frame(self) - implicit none - type(swiftest_storage_frame) :: self - end subroutine util_final_storage_frame - - pure module subroutine util_flatten_eucl_ij_to_k(n, i, j, k) - !$omp declare simd(util_flatten_eucl_ij_to_k) - implicit none - integer(I4B), intent(in) :: n !! Number of bodies - integer(I4B), intent(in) :: i !! Index of the ith body - integer(I4B), intent(in) :: j !! Index of the jth body - integer(I8B), intent(out) :: k !! Index of the flattened matrix - end subroutine util_flatten_eucl_ij_to_k - - pure module subroutine util_flatten_eucl_k_to_ij(n, k, i, j) - implicit none - integer(I4B), intent(in) :: n !! Number of bodies - integer(I8B), intent(in) :: k !! Index of the flattened matrix - integer(I4B), intent(out) :: i !! Index of the ith body - integer(I4B), intent(out) :: j !! Index of the jth body - end subroutine util_flatten_eucl_k_to_ij - - module subroutine util_flatten_eucl_plpl(self, param) - implicit none - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine - - module subroutine util_flatten_eucl_pltp(self, pl, param) - implicit none - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - class(swiftest_pl), intent(in) :: pl !! Swiftest massive body object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine - - module subroutine util_get_vals_storage(self, idvals, tvals) - class(swiftest_storage(*)), intent(in) :: self !! Swiftest storage object - integer(I4B), dimension(:), allocatable, intent(out) :: idvals !! Array of all id values in all snapshots - real(DP), dimension(:), allocatable, intent(out) :: tvals !! Array of all time values in all snapshots - end subroutine util_get_vals_storage - - module subroutine util_index_array(ind_arr, n) - implicit none - integer(I4B), dimension(:), allocatable, intent(inout) :: ind_arr !! Index array. Input is a pre-existing index array where n /= size(ind_arr). Output is a new index array ind_arr = [1, 2, ... n] - integer(I4B), intent(in) :: n !! The new size of the index array - end subroutine util_index_array - - module subroutine util_index_map_storage(self) - implicit none - class(swiftest_storage(*)), intent(inout) :: self !! Swiftest storage object - end subroutine util_index_map_storage - - module subroutine util_minimize_bfgs(f, N, x0, eps, maxloop, lerr, x1) - use lambda_function - implicit none - integer(I4B), intent(in) :: N - class(lambda_obj), intent(inout) :: f - real(DP), dimension(:), intent(in) :: x0 - real(DP), intent(in) :: eps - logical, intent(out) :: lerr - integer(I4B), intent(in) :: maxloop - real(DP), dimension(:), allocatable, intent(out) :: x1 - end subroutine util_minimize_bfgs - - module subroutine util_peri_tp(self, system, param) - implicit none - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - end subroutine util_peri_tp - - module subroutine util_rescale_system(self, param, mscale, dscale, tscale) - implicit none - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters. Returns with new values of the scale vactors and GU - real(DP), intent(in) :: mscale, dscale, tscale !! Scale factors for mass, distance, and time units, respectively. - end subroutine util_rescale_system - - module subroutine util_reset_storage(self) - implicit none - class(swiftest_storage(*)), intent(inout) :: self !! Swiftest storage object - end subroutine util_reset_storage - end interface - - - interface util_resize - module subroutine util_resize_arr_char_string(arr, nnew) - implicit none - character(len=STRMAX), dimension(:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size - end subroutine util_resize_arr_char_string - - module subroutine util_resize_arr_DP(arr, nnew) - implicit none - real(DP), dimension(:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size - end subroutine util_resize_arr_DP - - module subroutine util_resize_arr_DPvec(arr, nnew) - implicit none - real(DP), dimension(:,:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size - end subroutine util_resize_arr_DPvec - - module subroutine util_resize_arr_I4B(arr, nnew) - implicit none - integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size - end subroutine util_resize_arr_I4B - - module subroutine util_resize_arr_info(arr, nnew) - implicit none - type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size - end subroutine util_resize_arr_info - - module subroutine util_resize_arr_logical(arr, nnew) - implicit none - logical, dimension(:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size - end subroutine util_resize_arr_logical - end interface - - interface - module subroutine util_resize_body(self, nnew) - implicit none - class(swiftest_body), intent(inout) :: self !! Swiftest body object - integer(I4B), intent(in) :: nnew !! New size neded - end subroutine util_resize_body - - module subroutine util_resize_pl(self, nnew) - implicit none - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - integer(I4B), intent(in) :: nnew !! New size neded - end subroutine util_resize_pl - - module subroutine util_resize_tp(self, nnew) - implicit none - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - integer(I4B), intent(in) :: nnew !! New size neded - end subroutine util_resize_tp - - module subroutine util_get_energy_momentum_system(self, param) - implicit none - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - end subroutine util_get_energy_momentum_system - - module subroutine util_get_idvalues_system(self, idvals) - implicit none - class(swiftest_nbody_system), intent(in) :: self !! Encounter snapshot object - integer(I4B), dimension(:), allocatable, intent(out) :: idvals !! Array of all id values saved in this snapshot - end subroutine util_get_idvalues_system - - module subroutine util_set_beg_end_pl(self, rbeg, xend, vbeg) - implicit none - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - real(DP), dimension(:,:), intent(in), optional :: rbeg !! Position vectors at beginning of step - real(DP), dimension(:,:), intent(in), optional :: xend !! Positions vectors at end of step - real(DP), dimension(:,:), intent(in), optional :: vbeg !! vbeg is an unused variable to keep this method forward compatible with RMVS - end subroutine util_set_beg_end_pl - - module subroutine util_set_ir3h(self) - implicit none - class(swiftest_body), intent(inout) :: self !! Swiftest body object - end subroutine util_set_ir3h - - module subroutine util_set_msys(self) - implicit none - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest system object - end subroutine util_set_msys - - module subroutine util_set_mu_pl(self, cb) - implicit none - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object - end subroutine util_set_mu_pl - - module subroutine util_set_mu_tp(self, cb) - implicit none - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object - end subroutine util_set_mu_tp - - module subroutine util_set_particle_info(self, name, particle_type, status, origin_type, origin_time, collision_id, & - origin_rh, origin_vh, discard_time, discard_rh, discard_vh, discard_body_id) - implicit none - class(swiftest_particle_info), intent(inout) :: self - character(len=*), intent(in), optional :: name !! Non-unique name - character(len=*), intent(in), optional :: particle_type !! String containing a description of the particle type (e.g. Central Body, Massive Body, Test Particle) - character(len=*), intent(in), optional :: status !! Particle status description: Active, Merged, Fragmented, etc. - character(len=*), intent(in), optional :: origin_type !! String containing a description of the origin of the particle (e.g. Initial Conditions, Supercatastrophic, Disruption, etc.) - real(DP), intent(in), optional :: origin_time !! The time of the particle's formation - integer(I4B), intent(in), optional :: collision_id !! The ID fo the collision that formed the particle - real(DP), dimension(:), intent(in), optional :: origin_rh !! The heliocentric distance vector at the time of the particle's formation - real(DP), dimension(:), intent(in), optional :: origin_vh !! The heliocentric velocity vector at the time of the particle's formation - real(DP), intent(in), optional :: discard_time !! The time of the particle's discard - real(DP), dimension(:), intent(in), optional :: discard_rh !! The heliocentric distance vector at the time of the particle's discard - real(DP), dimension(:), intent(in), optional :: discard_vh !! The heliocentric velocity vector at the time of the particle's discard - integer(I4B), intent(in), optional :: discard_body_id !! The id of the other body involved in the discard (0 if no other body involved) - end subroutine util_set_particle_info - - module subroutine util_set_rhill(self,cb) - implicit none - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object - end subroutine util_set_rhill - - module subroutine util_set_renc_I4B(self, scale) - implicit none - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - integer(I4B), intent(in) :: scale !! Input scale factor (multiplier of Hill's sphere size) - end subroutine util_set_renc_I4B - - module subroutine util_set_renc_DP(self, scale) - implicit none - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - real(DP), intent(in) :: scale !! Input scale factor (multiplier of Hill's sphere size) - end subroutine util_set_renc_DP - - module subroutine util_set_rhill_approximate(self,cb) - implicit none - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object - end subroutine util_set_rhill_approximate - - module subroutine util_snapshot_system(self, param, system, t, arg) - implicit none - class(swiftest_storage(*)), intent(inout) :: self !! Swiftest storage object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object to store - real(DP), intent(in), optional :: t !! Time of snapshot if different from system time - character(*), intent(in), optional :: arg !! Optional argument (needed for extended storage type used in encounter snapshots) - end subroutine util_snapshot_system - end interface - - interface util_solve_linear_system - module function util_solve_linear_system_d(A,b,n,lerr) result(x) - implicit none - integer(I4B), intent(in) :: n - real(DP), dimension(:,:), intent(in) :: A - real(DP), dimension(:), intent(in) :: b - logical, intent(out) :: lerr - real(DP), dimension(n) :: x - end function util_solve_linear_system_d - - module function util_solve_linear_system_q(A,b,n,lerr) result(x) - implicit none - integer(I4B), intent(in) :: n - real(QP), dimension(:,:), intent(in) :: A - real(QP), dimension(:), intent(in) :: b - logical, intent(out) :: lerr - real(QP), dimension(n) :: x - end function util_solve_linear_system_q - end interface - - interface - module function util_solve_rkf45(f, y0in, t1, dt0, tol) result(y1) - use lambda_function - implicit none - class(lambda_obj), intent(inout) :: f !! lambda function object that has been initialized to be a function of derivatives. The object will return with components lastarg and lasteval set - real(DP), dimension(:), intent(in) :: y0in !! Initial value at t=0 - real(DP), intent(in) :: t1 !! Final time - real(DP), intent(in) :: dt0 !! Initial step size guess - real(DP), intent(in) :: tol !! Tolerance on solution - real(DP), dimension(:), allocatable :: y1 !! Final result - end function util_solve_rkf45 - end interface - - interface util_sort - pure module subroutine util_sort_i4b(arr) - implicit none - integer(I4B), dimension(:), intent(inout) :: arr - end subroutine util_sort_i4b - - pure module subroutine util_sort_index_i4b(arr,ind) - implicit none - integer(I4B), dimension(:), intent(in) :: arr - integer(I4B), dimension(:), allocatable, intent(inout) :: ind - end subroutine util_sort_index_i4b - - pure module subroutine util_sort_index_I4B_I8Bind(arr,ind) - implicit none - integer(I4B), dimension(:), intent(in) :: arr - integer(I8B), dimension(:), allocatable, intent(inout) :: ind - end subroutine util_sort_index_I4b_I8Bind - - pure module subroutine util_sort_index_I8B_I8Bind(arr,ind) - implicit none - integer(I8B), dimension(:), intent(in) :: arr - integer(I8B), dimension(:), allocatable, intent(inout) :: ind - end subroutine util_sort_index_I8B_I8Bind - - pure module subroutine util_sort_sp(arr) - implicit none - real(SP), dimension(:), intent(inout) :: arr - end subroutine util_sort_sp - - pure module subroutine util_sort_index_sp(arr,ind) - implicit none - real(SP), dimension(:), intent(in) :: arr - integer(I4B), dimension(:), allocatable, intent(inout) :: ind - end subroutine util_sort_index_sp - - pure module subroutine util_sort_dp(arr) - implicit none - real(DP), dimension(:), intent(inout) :: arr - end subroutine util_sort_dp - - pure module subroutine util_sort_index_dp(arr,ind) - implicit none - real(DP), dimension(:), intent(in) :: arr - integer(I4B), dimension(:), allocatable, intent(inout) :: ind - end subroutine util_sort_index_dp - end interface util_sort - - interface util_sort_rearrange - pure module subroutine util_sort_rearrange_arr_char_string(arr, ind, n) - implicit none - character(len=STRMAX), dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange - end subroutine util_sort_rearrange_arr_char_string - - pure module subroutine util_sort_rearrange_arr_DP(arr, ind, n) - implicit none - real(DP), dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange - end subroutine util_sort_rearrange_arr_DP - - pure module subroutine util_sort_rearrange_arr_DPvec(arr, ind, n) - implicit none - real(DP), dimension(:,:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange - end subroutine util_sort_rearrange_arr_DPvec - - pure module subroutine util_sort_rearrange_arr_I4B(arr, ind, n) - implicit none - integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange - end subroutine util_sort_rearrange_arr_I4B - - pure module subroutine util_sort_rearrange_arr_I4B_I8Bind(arr, ind, n) - implicit none - integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I8B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I8B), intent(in) :: n !! Number of elements in arr and ind to rearrange - end subroutine util_sort_rearrange_arr_I4B_I8Bind - - module subroutine util_sort_rearrange_arr_info(arr, ind, n) - implicit none - type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange - end subroutine util_sort_rearrange_arr_info - - pure module subroutine util_sort_rearrange_arr_logical(arr, ind, n) - implicit none - logical, dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange - end subroutine util_sort_rearrange_arr_logical - - pure module subroutine util_sort_rearrange_arr_logical_I8Bind(arr, ind, n) - implicit none - logical, dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I8B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I8B), intent(in) :: n !! Number of elements in arr and ind to rearrange - end subroutine util_sort_rearrange_arr_logical_I8Bind - end interface util_sort_rearrange - - interface - module subroutine util_sort_rearrange_body(self, ind) - implicit none - class(swiftest_body), intent(inout) :: self !! Swiftest 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 util_sort_rearrange_body - - module subroutine util_sort_rearrange_pl(self, ind) - implicit none - class(swiftest_pl), intent(inout) :: self !! Swiftest 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 util_sort_rearrange_pl - - module subroutine util_sort_rearrange_tp(self, ind) - implicit none - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle 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 util_sort_rearrange_tp - - module subroutine util_sort_body(self, sortby, ascending) - implicit none - class(swiftest_body), intent(inout) :: self !! Swiftest body object - character(*), intent(in) :: sortby !! Sorting attribute - logical, intent(in) :: ascending !! Logical flag indicating whether or not the sorting should be in ascending or descending order - end subroutine util_sort_body - - module subroutine util_sort_pl(self, sortby, ascending) - implicit none - class(swiftest_pl), intent(inout) :: self !! Swiftest body object - character(*), intent(in) :: sortby !! Sorting attribute - logical, intent(in) :: ascending !! Logical flag indicating whether or not the sorting should be in ascending or descending order - end subroutine util_sort_pl - - module subroutine util_sort_tp(self, sortby, ascending) - implicit none - class(swiftest_tp), intent(inout) :: self !! Swiftest body object - character(*), intent(in) :: sortby !! Sorting attribute - logical, intent(in) :: ascending !! Logical flag indicating whether or not the sorting should be in ascending or descending order - end subroutine util_sort_tp - - end interface - - - - interface util_spill - module subroutine util_spill_arr_char_string(keeps, discards, lspill_list, ldestructive) - implicit none - character(len=STRMAX), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - character(len=STRMAX), 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 util_spill_arr_char_string - - module subroutine util_spill_arr_DP(keeps, discards, lspill_list, ldestructive) - implicit none - real(DP), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - real(DP), dimension(:), allocatable, intent(inout) :: discards !! Array of discards - 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 util_spill_arr_DP - - module subroutine util_spill_arr_DPvec(keeps, discards, lspill_list, ldestructive) - implicit none - real(DP), dimension(:,:), allocatable, intent(inout) :: keeps !! Array of values to keep - real(DP), dimension(:,:), allocatable, intent(inout) :: discards !! Array discards - 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 util_spill_arr_DPvec - - module subroutine util_spill_arr_I4B(keeps, discards, lspill_list, ldestructive) - implicit none - integer(I4B), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - integer(I4B), 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 util_spill_arr_I4B - - module subroutine util_spill_arr_I8B(keeps, discards, lspill_list, ldestructive) - implicit none - integer(I8B), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - integer(I8B), 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 util_spill_arr_I8B - - module subroutine util_spill_arr_info(keeps, discards, lspill_list, ldestructive) - implicit none - type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - type(swiftest_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 util_spill_arr_info - - module subroutine util_spill_arr_logical(keeps, discards, lspill_list, ldestructive) - implicit none - logical, dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - logical, 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 util_spill_arr_logical - end interface - - interface - module subroutine util_spill_body(self, discards, lspill_list, ldestructive) - implicit none - class(swiftest_body), intent(inout) :: self !! Swiftest 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 util_spill_body - - module subroutine util_spill_pl(self, discards, lspill_list, ldestructive) - implicit none - class(swiftest_pl), intent(inout) :: self !! Swiftest 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 util_spill_pl - - module subroutine util_spill_tp(self, discards, lspill_list, ldestructive) - implicit none - class(swiftest_tp), intent(inout) :: self !! Swiftest 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 util_spill_tp - - end interface - - interface util_unique - module subroutine util_unique_DP(input_array, output_array, index_map) - implicit none - real(DP), dimension(:), intent(in) :: input_array !! Unsorted input array - real(DP), dimension(:), allocatable, intent(out) :: output_array !! Sorted array of unique values - integer(I4B), dimension(:), allocatable, intent(out) :: index_map !! An array of the same size as input_array that such that any for any index i, output_array(index_map(i)) = input_array(i) - end subroutine util_unique_DP - - module subroutine util_unique_I4B(input_array, output_array, index_map) - implicit none - integer(I4B), dimension(:), intent(in) :: input_array !! Unsorted input array - integer(I4B), dimension(:), allocatable, intent(out) :: output_array !! Sorted array of unique values - integer(I4B), dimension(:), allocatable, intent(out) :: index_map !! An array of the same size as input_array that such that any for any index i, output_array(index_map(i)) = input_array(i) - end subroutine util_unique_I4B - end interface util_unique - - interface - module subroutine util_valid_id_system(self, param) - implicit none - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine util_valid_id_system - - module subroutine util_version() - implicit none - end subroutine util_version - end interface - -end module swiftest_classes diff --git a/src/modules/symba_classes.f90 b/src/modules/symba.f90 similarity index 55% rename from src/modules/symba_classes.f90 rename to src/modules/symba.f90 index 86988fc9e..419a2b711 100644 --- a/src/modules/symba_classes.f90 +++ b/src/modules/symba.f90 @@ -7,17 +7,13 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -module symba_classes +module symba !! author: The Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott !! !! Definition of classes and methods specific to the SyMBA integrator !! Adapted from David E. Kaufmann's Swifter routine: module_symba.f90 - use swiftest_globals - use swiftest_classes, only : swiftest_parameters, swiftest_base, swiftest_particle_info, swiftest_storage, netcdf_parameters - use helio_classes, only : helio_cb, helio_pl, helio_tp, helio_nbody_system - use fraggle_classes, only : collision_impactors, fraggle_fragments - use encounter_classes, only : encounter_list, encounter_storage - use collision_classes, only : collision_storage, collision_system + use swiftest + use helio implicit none public @@ -26,66 +22,17 @@ module symba_classes real(DP), private, parameter :: RHSCALE = 6.5_DP real(DP), private, parameter :: RSHELL = 0.48075_DP - type, extends(swiftest_parameters) :: symba_parameters - real(DP) :: GMTINY = -1.0_DP !! Smallest G*mass that is fully gravitating - real(DP) :: min_GMfrag = -1.0_DP !! Smallest G*mass that can be produced in a fragmentation event - integer(I4B), dimension(:), allocatable :: seed !! Random seeds for fragmentation modeling - logical :: lfragmentation = .false. !! Do fragmentation modeling instead of simple merger. - character(STRMAX) :: encounter_save = "NONE" !! Indicate if and how encounter data should be saved - logical :: lenc_save_trajectory = .false. !! Indicates that when encounters are saved, the full trajectory through recursion steps are saved - logical :: lenc_save_closest = .false. !! Indicates that when encounters are saved, the closest approach distance between pairs of bodies is saved - type(encounter_storage(nframes=:)), allocatable :: encounter_history !! Stores encounter history for later retrieval and saving to file - type(collision_storage(nframes=:)), allocatable :: collision_history !! Stores encounter history for later retrieval and saving to file - contains - procedure :: reader => symba_io_param_reader - procedure :: writer => symba_io_param_writer - end type symba_parameters - - !******************************************************************************************************************************** - ! symba_kinship class definitions and method interfaces - !******************************************************************************************************************************* - !> Class definition for the kinship relationships used in bookkeeping multiple collisions bodies in a single time step. - type symba_kinship - integer(I4B) :: parent !! Index of parent particle - integer(I4B) :: nchild !! number of children in merger list - integer(I4B), dimension(:), allocatable :: child !! Index of children particles - contains - procedure :: dealloc => symba_util_dealloc_kin !! Deallocates all allocatable arrays - final :: symba_util_final_kin !! Finalizes the SyMBA kinship object - deallocates all allocatables - end type symba_kinship - !******************************************************************************************************************************** - ! symba_cb class definitions and method interfaces - !******************************************************************************************************************************* !> SyMBA central body particle class type, extends(helio_cb) :: symba_cb - real(DP) :: GM0 = 0.0_DP !! Initial G*mass of the central body - real(DP) :: dGM = 0.0_DP !! Change in G*mass of the central body - real(DP) :: R0 = 0.0_DP !! Initial radius of the central body - real(DP) :: dR = 0.0_DP !! Change in the radius of the central body - contains end type symba_cb - !******************************************************************************************************************************** - ! symba_pl class definitions and method interfaces - !******************************************************************************************************************************* + !> SyMBA massive body class type, extends(helio_pl) :: symba_pl - logical, dimension(:), allocatable :: lcollision !! flag indicating whether body has merged with another this time step - logical, dimension(:), allocatable :: lencounter !! flag indicating whether body is part of an encounter this time step - logical, dimension(:), allocatable :: lmtiny !! flag indicating whether this body is below the GMTINY cutoff value - integer(I4B) :: nplm !! number of bodies above the GMTINY limit - integer(I8B) :: nplplm !! Number of body (all massive)-body (only those above GMTINY) comparisons in the flattened upper triangular matrix - integer(I4B), dimension(:), allocatable :: nplenc !! number of encounters with other planets this time step - integer(I4B), dimension(:), allocatable :: ntpenc !! number of encounters with test particles this time step integer(I4B), dimension(:), allocatable :: levelg !! level at which this body should be moved integer(I4B), dimension(:), allocatable :: levelm !! deepest encounter level achieved this time step - integer(I4B), dimension(:), allocatable :: isperi !! perihelion passage flag - real(DP), dimension(:), allocatable :: peri !! perihelion distance - real(DP), dimension(:), allocatable :: atp !! semimajor axis following perihelion passage - type(symba_kinship), dimension(:), allocatable :: kin !! Array of merger relationship structures that can account for multiple pairwise mergers in a single step contains - procedure :: make_impactors => symba_collision_make_impactors_pl !! When a single body is involved in more than one collision in a single step, it becomes part of a family procedure :: flatten => symba_util_flatten_eucl_plpl !! Sets up the (i, j) -> k indexing used for the single-loop blocking Euclidean distance matrix procedure :: discard => symba_discard_pl !! Process massive body discards procedure :: drift => symba_drift_pl !! Method for Danby drift in Democratic Heliocentric coordinates. Sets the mask to the current recursion level @@ -98,8 +45,6 @@ module symba_classes procedure :: dealloc => symba_util_dealloc_pl !! Deallocates all allocatable arrays procedure :: fill => symba_util_fill_pl !! "Fills" bodies from one object into another depending on the results of a mask (uses the UNPACK intrinsic) procedure :: get_peri => symba_util_peri_pl !! Determine system pericenter passages for massive bodies - procedure :: rearray => symba_util_rearray_pl !! Clean up the massive body structures to remove discarded bodies and add new bodies - procedure :: reset_kinship => symba_util_reset_kinship !! Resets the kinship status of bodies procedure :: resize => symba_util_resize_pl !! Checks the current size of a SyMBA massive body against the requested size and resizes it if it is too small. procedure :: set_renc_I4B => symba_util_set_renc !! Sets the critical radius for encounter given an input recursion depth procedure :: sort => symba_util_sort_pl !! Sorts body arrays by a sortable componen @@ -108,22 +53,9 @@ module symba_classes final :: symba_util_final_pl !! Finalizes the SyMBA massive body object - deallocates all allocatables end type symba_pl - type, extends(symba_pl) :: symba_merger - integer(I4B), dimension(:), allocatable :: ncomp - contains - procedure :: append => symba_util_append_merger !! Appends elements from one structure to another - procedure :: dealloc => symba_util_dealloc_merger !! Deallocates all allocatable arrays - procedure :: resize => symba_util_resize_merger !! Checks the current size of a SyMBA merger list against the requested size and resizes it if it is too small. - procedure :: setup => symba_setup_merger !! Constructor method - Allocates space for the input number of bodies - final :: symba_util_final_merger !! Finalizes the SyMBA merger object - deallocates all allocatables - end type symba_merger - - !******************************************************************************************************************************** - ! symba_tp class definitions and method interfaces - !******************************************************************************************************************************* + !> SyMBA test particle class type, extends(helio_tp) :: symba_tp - integer(I4B), dimension(:), allocatable :: nplenc !! number of encounters with planets this time step integer(I4B), dimension(:), allocatable :: levelg !! level at which this particle should be moved integer(I4B), dimension(:), allocatable :: levelm !! deepest encounter level achieved this time step contains @@ -142,15 +74,11 @@ module symba_classes final :: symba_util_final_tp !! Finalizes the SyMBA test particle object - deallocates all allocatables end type symba_tp - !******************************************************************************************************************************** - ! symba_encounter class definitions and method interfaces - !******************************************************************************************************************************* + !> SyMBA class for tracking close encounters in a step type, extends(encounter_list) :: symba_encounter integer(I4B), dimension(:), allocatable :: level !! encounter recursion level - real(DP), dimension(:), allocatable :: tcollision !! Time of collision contains - procedure :: collision_check => symba_collision_check_encounter !! Checks if a test particle is going to collide with a massive body procedure :: encounter_check => symba_encounter_check !! Checks if massive bodies are going through close encounters with each other procedure :: kick => symba_kick_encounter !! Kick barycentric velocities of active test particles within SyMBA recursion procedure :: setup => symba_setup_encounter_list !! A constructor that sets the number of encounters and allocates and initializes all arrays @@ -161,38 +89,10 @@ module symba_classes final :: symba_util_final_encounter_list !! Finalizes the SyMBA test particle object - deallocates all allocatables end type symba_encounter - !******************************************************************************************************************************** - ! symba_pltpenc class definitions and method interfaces - !******************************************************************************************************************************* - !> SyMBA class for tracking pl-tp close encounters in a step - type, extends(symba_encounter) :: symba_pltpenc - contains - procedure :: resolve_collision => symba_resolve_collision_pltpenc !! Process the pl-tp collision list, then modifiy the massive bodies based on the outcome of the c - end type symba_pltpenc - - !******************************************************************************************************************************** - ! symba_plplenc class definitions and method interfaces - !******************************************************************************************************************************* - !> SyMBA class for tracking pl-pl close encounters in a step - type, extends(symba_encounter) :: symba_plplenc - contains - procedure :: extract_collisions => symba_collision_extract_collisions_from_encounters !! Processes the pl-pl encounter list remove only those encounters that led to a collision - procedure :: resolve_collision => symba_resolve_collision_plplenc !! Process the pl-pl collision list, then modifiy the massive bodies based on the outcome of the c - end type symba_plplenc - - !******************************************************************************************************************************** - ! symba_nbody_system class definitions and method interfaces - !******************************************************************************************************************************** type, extends(helio_nbody_system) :: symba_nbody_system - class(symba_merger), allocatable :: pl_adds !! List of added bodies in mergers or collisions - class(symba_pltpenc), allocatable :: pltpenc_list !! List of massive body-test particle encounters in a single step - class(symba_plplenc), allocatable :: plplenc_list !! List of massive body-massive body encounters in a single step - class(symba_plplenc), allocatable :: plplcollision_list !! List of massive body-massive body collisions in a single step integer(I4B) :: irec !! System recursion level - class(collision_system), allocatable :: collision_system !! Collision system object contains - procedure :: write_discard => symba_io_write_discard !! Write out information about discarded and merged planets and test particles in SyMBA procedure :: initialize => symba_setup_initialize_system !! Performs SyMBA-specific initilization steps procedure :: step => symba_step_system !! Advance the SyMBA nbody system forward in time by one step procedure :: interp => symba_step_interp_system !! Perform an interpolation step on the SymBA nbody system @@ -204,54 +104,7 @@ module symba_classes interface - - module subroutine symba_collision_check_encounter(self, system, param, t, dt, irec, lany_collision) - use swiftest_classes, only : swiftest_parameters - implicit none - class(symba_encounter), intent(inout) :: self !! SyMBA pl-tp encounter list object - class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - real(DP), intent(in) :: t !! current time - real(DP), intent(in) :: dt !! step size - integer(I4B), intent(in) :: irec !! Current recursion level - logical, intent(out) :: lany_collision !! Returns true if any pair of encounters resulted in a collision - end subroutine symba_collision_check_encounter - - module subroutine symba_collision_extract_collisions_from_encounters(self, system, param) - implicit none - class(symba_plplenc), intent(inout) :: self !! SyMBA pl-pl encounter list - class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - end subroutine - - module subroutine symba_collision_make_impactors_pl(self,idx) - implicit none - class(symba_pl), intent(inout) :: self !! SyMBA massive body object - integer(I4B), dimension(2), intent(in) :: idx !! Array holding the indices of the two bodies involved in the collision - end subroutine symba_collision_make_impactors_pl - - module subroutine symba_resolve_collision_plplenc(self, system, param, t, dt, irec) - implicit none - class(symba_plplenc), intent(inout) :: self !! SyMBA pl-pl encounter list - class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions - real(DP), intent(in) :: t !! Current simulation time - real(DP), intent(in) :: dt !! Current simulation step size - integer(I4B), intent(in) :: irec !! Current recursion level - end subroutine symba_resolve_collision_plplenc - - module subroutine symba_resolve_collision_pltpenc(self, system, param, t, dt, irec) - implicit none - class(symba_pltpenc), intent(inout) :: self !! SyMBA pl-tp encounter list - class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions - real(DP), intent(in) :: t !! Current simulation time - real(DP), intent(in) :: dt !! Current simulation step size - integer(I4B), intent(in) :: irec !! Current recursion level - end subroutine symba_resolve_collision_pltpenc - module subroutine symba_discard_pl(self, system, param) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters implicit none class(symba_pl), intent(inout) :: self !! SyMBA test particle object class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object @@ -259,7 +112,6 @@ module subroutine symba_discard_pl(self, system, param) end subroutine symba_discard_pl module subroutine symba_drift_pl(self, system, param, dt) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters implicit none class(symba_pl), intent(inout) :: self !! Helio massive body object class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object @@ -268,7 +120,6 @@ module subroutine symba_drift_pl(self, system, param, dt) end subroutine symba_drift_pl module subroutine symba_drift_tp(self, system, param, dt) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters implicit none class(symba_tp), intent(inout) :: self !! Helio massive body object class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object @@ -277,7 +128,6 @@ module subroutine symba_drift_tp(self, system, param, dt) end subroutine symba_drift_tp module function symba_encounter_check_pl(self, param, system, dt, irec) result(lany_encounter) - use swiftest_classes, only : swiftest_nbody_system implicit none class(symba_pl), intent(inout) :: self !! SyMBA test particle object class(swiftest_parameters), intent(inout) :: param !! Current swiftest run configuration parameters @@ -288,7 +138,6 @@ module function symba_encounter_check_pl(self, param, system, dt, irec) result(l end function symba_encounter_check_pl module function symba_encounter_check(self, param, system, dt, irec) result(lany_encounter) - use swiftest_classes, only : swiftest_parameters implicit none class(symba_encounter), intent(inout) :: self !! SyMBA pl-pl encounter list object class(swiftest_parameters), intent(inout) :: param !! Current swiftest run configuration parameters @@ -299,7 +148,6 @@ module function symba_encounter_check(self, param, system, dt, irec) result(lany end function symba_encounter_check module function symba_encounter_check_tp(self, param, system, dt, irec) result(lany_encounter) - use swiftest_classes, only : swiftest_parameters implicit none class(symba_tp), intent(inout) :: self !! SyMBA test particle object class(swiftest_parameters), intent(inout) :: param !! Current swiftest run configuration parameters @@ -310,7 +158,6 @@ module function symba_encounter_check_tp(self, param, system, dt, irec) result(l end function symba_encounter_check_tp pure module subroutine symba_gr_p4_pl(self, system, param, dt) - use swiftest_classes, only : swiftest_parameters, swiftest_nbody_system implicit none class(symba_pl), intent(inout) :: self !! SyMBA massive body object class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object @@ -319,7 +166,6 @@ pure module subroutine symba_gr_p4_pl(self, system, param, dt) end subroutine symba_gr_p4_pl pure module subroutine symba_gr_p4_tp(self, system, param, dt) - use swiftest_classes, only : swiftest_parameters, swiftest_nbody_system implicit none class(symba_tp), intent(inout) :: self !! SyMBA test particle object class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object @@ -327,50 +173,15 @@ pure module subroutine symba_gr_p4_tp(self, system, param, dt) real(DP), intent(in) :: dt !! Step size end subroutine symba_gr_p4_tp - module function symba_collision_casedisruption(system, param, t) result(status) - implicit none - class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object - class(symba_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions - real(DP), intent(in) :: t !! Time of collision - integer(I4B) :: status !! Status flag assigned to this outcome - end function symba_collision_casedisruption - - module function symba_collision_casehitandrun(system, param, t) result(status) - implicit none - class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object - class(symba_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions - real(DP), intent(in) :: t !! Time of collision - integer(I4B) :: status !! Status flag assigned to this outcome - end function symba_collision_casehitandrun - - module function symba_collision_casemerge(system, param, t) result(status) - implicit none - class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object - class(symba_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions - real(DP), intent(in) :: t !! Time of collision - integer(I4B) :: status !! Status flag assigned to this outcome - end function symba_collision_casemerge - module subroutine symba_util_set_renc(self, scale) implicit none class(symba_pl), intent(inout) :: self !! SyMBA massive body object integer(I4B), intent(in) :: scale !! Current recursion depth end subroutine symba_util_set_renc - - module subroutine symba_io_param_reader(self, unit, iotype, v_list, iostat, iomsg) - implicit none - class(symba_parameters), intent(inout) :: self !! Current run configuration parameters with SyMBA additionss - integer, intent(in) :: unit !! File unit number - character(len=*), intent(in) :: iotype !! Dummy argument passed to the input/output procedure contains the text from the char-literal-constant, prefixed with DT. - !! If you do not include a char-literal-constant, the iotype argument contains only DT. - character(len=*), intent(in) :: v_list(:) !! The first element passes the integrator code to the reader - integer, intent(out) :: iostat !! IO status code - character(len=*), intent(inout) :: iomsg !! Message to pass if iostat /= 0 - end subroutine symba_io_param_reader module subroutine symba_io_param_writer(self, unit, iotype, v_list, iostat, iomsg) implicit none - class(symba_parameters),intent(in) :: self !! Current run configuration parameters with SyMBA additions + class(swiftest_parameters),intent(in) :: self !! Current run configuration parameters with SyMBA additions integer, intent(in) :: unit !! File unit number character(len=*), intent(in) :: iotype !! Dummy argument passed to the input/output procedure contains the text from the char-literal-constant, prefixed with DT. !! If you do not include a char-literal-constant, the iotype argument contains only DT. @@ -379,13 +190,6 @@ module subroutine symba_io_param_writer(self, unit, iotype, v_list, iostat, ioms character(len=*), intent(inout) :: iomsg !! Message to pass if iostat /= 0 end subroutine symba_io_param_writer - module subroutine symba_io_write_discard(self, param) - use swiftest_classes, only : swiftest_parameters - implicit none - class(symba_nbody_system), intent(inout) :: self !! SyMBA nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - end subroutine symba_io_write_discard - module subroutine symba_kick_getacch_int_pl(self, param) implicit none class(symba_pl), intent(inout) :: self !! SyMBA massive body object @@ -393,7 +197,6 @@ module subroutine symba_kick_getacch_int_pl(self, param) end subroutine symba_kick_getacch_int_pl module subroutine symba_kick_getacch_pl(self, system, param, t, lbeg) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters implicit none class(symba_pl), intent(inout) :: self !! SyMBA massive body particle data structure class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object @@ -403,7 +206,6 @@ module subroutine symba_kick_getacch_pl(self, system, param, t, lbeg) end subroutine symba_kick_getacch_pl module subroutine symba_kick_getacch_tp(self, system, param, t, lbeg) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters implicit none class(symba_tp), intent(inout) :: self !! SyMBA test particle data structure class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object @@ -422,22 +224,13 @@ module subroutine symba_kick_encounter(self, system, dt, irec, sgn) end subroutine symba_kick_encounter module subroutine symba_setup_initialize_system(self, param) - use swiftest_classes, only : swiftest_parameters implicit none class(symba_nbody_system), intent(inout) :: self !! SyMBA system object class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters end subroutine symba_setup_initialize_system - module subroutine symba_setup_merger(self, n, param) - use swiftest_classes, only : swiftest_parameters - implicit none - class(symba_merger), intent(inout) :: self !! SyMBA merger list object - integer(I4B), intent(in) :: n !! Number of particles to allocate space for - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - end subroutine symba_setup_merger module subroutine symba_setup_pl(self, n, param) - use swiftest_classes, only : swiftest_parameters implicit none class(symba_pl), intent(inout) :: self !! SyMBA massive body object integer(I4B), intent(in) :: n !! Number of particles to allocate space for @@ -451,7 +244,6 @@ module subroutine symba_setup_encounter_list(self,n) end subroutine symba_setup_encounter_list module subroutine symba_setup_tp(self, n, param) - use swiftest_classes, only : swiftest_parameters implicit none class(symba_tp), intent(inout) :: self !! SyMBA test particle object integer(I4B), intent(in) :: n !! Number of particles to allocate space for @@ -459,7 +251,6 @@ module subroutine symba_setup_tp(self, n, param) end subroutine symba_setup_tp module subroutine symba_step_system(self, param, t, dt) - use swiftest_classes, only : swiftest_parameters implicit none class(symba_nbody_system), intent(inout) :: self !! SyMBA nbody system object class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters @@ -468,7 +259,6 @@ module subroutine symba_step_system(self, param, t, dt) end subroutine symba_step_system module subroutine symba_step_interp_system(self, param, t, dt) - use swiftest_classes, only : swiftest_parameters implicit none class(symba_nbody_system), intent(inout) :: self !! SyMBA nbody system object class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters @@ -483,7 +273,6 @@ module subroutine symba_step_set_recur_levels_system(self, ireci) end subroutine symba_step_set_recur_levels_system recursive module subroutine symba_step_recur_system(self, param, t, ireci) - use swiftest_classes, only : swiftest_parameters implicit none class(symba_nbody_system), intent(inout) :: self !! SyMBA nbody system object class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters @@ -494,21 +283,9 @@ end subroutine symba_step_recur_system module subroutine symba_step_reset_system(self, param) implicit none class(symba_nbody_system), intent(inout) :: self !! SyMBA nbody system object - class(symba_parameters), intent(in) :: param !! Current run configuration parameters with SyMBA additions + class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters with SyMBA additions end subroutine symba_step_reset_system - end interface - interface util_append - 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 - - interface module subroutine symba_util_append_encounter_list(self, source, lsource_mask) implicit none class(symba_encounter), intent(inout) :: self !! SyMBA encounter list object @@ -516,16 +293,7 @@ module subroutine symba_util_append_encounter_list(self, source, lsource_mask) logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to end subroutine symba_util_append_encounter_list - module subroutine symba_util_append_merger(self, source, lsource_mask) - use swiftest_classes, only : swiftest_body - implicit none - class(symba_merger), intent(inout) :: self !! SyMBA massive body object - 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 symba_util_append_merger - module subroutine symba_util_append_pl(self, source, lsource_mask) - use swiftest_classes, only : swiftest_body implicit none class(symba_pl), intent(inout) :: self !! SyMBA massive body object class(swiftest_body), intent(in) :: source !! Source object to append @@ -533,7 +301,6 @@ module subroutine symba_util_append_pl(self, source, lsource_mask) end subroutine symba_util_append_pl module subroutine symba_util_append_tp(self, source, lsource_mask) - use swiftest_classes, only : swiftest_body implicit none class(symba_tp), intent(inout) :: self !! SyMBA test particle object class(swiftest_body), intent(in) :: source !! Source object to append @@ -541,7 +308,7 @@ module subroutine symba_util_append_tp(self, source, lsource_mask) end subroutine symba_util_append_tp module subroutine symba_util_copy_encounter_list(self, source) - use encounter_classes, only : encounter_list + use encounter, only : encounter_list implicit none class(symba_encounter), intent(inout) :: self !! Encounter list class(encounter_list), intent(in) :: source !! Source object to copy into @@ -552,16 +319,6 @@ module subroutine symba_util_dealloc_encounter_list(self) class(symba_encounter), intent(inout) :: self !! SyMBA encounter list end subroutine symba_util_dealloc_encounter_list - module subroutine symba_util_dealloc_kin(self) - implicit none - class(symba_kinship), intent(inout) :: self !! SyMBA kinship object - end subroutine symba_util_dealloc_kin - - module subroutine symba_util_dealloc_merger(self) - implicit none - class(symba_merger), intent(inout) :: self !! SyMBA body merger object - end subroutine symba_util_dealloc_merger - module subroutine symba_util_dealloc_pl(self) implicit none class(symba_pl), intent(inout) :: self !! SyMBA massive body object @@ -573,18 +330,9 @@ module subroutine symba_util_dealloc_tp(self) end subroutine symba_util_dealloc_tp end interface - interface util_fill - module subroutine symba_util_fill_arr_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_kin - end interface interface module subroutine symba_util_fill_pl(self, inserts, lfill_list) - use swiftest_classes, only : swiftest_body implicit none class(symba_pl), intent(inout) :: self !! SyMBA massive body object class(swiftest_body), intent(in) :: inserts !! Inserted object @@ -592,7 +340,6 @@ module subroutine symba_util_fill_pl(self, inserts, lfill_list) end subroutine symba_util_fill_pl module subroutine symba_util_fill_tp(self, inserts, lfill_list) - use swiftest_classes, only : swiftest_body implicit none class(symba_tp), intent(inout) :: self !! SyMBA test particle object class(swiftest_body), intent(in) :: inserts !! Inserted object @@ -600,7 +347,6 @@ module subroutine symba_util_fill_tp(self, inserts, lfill_list) end subroutine symba_util_fill_tp module subroutine symba_util_flatten_eucl_plpl(self, param) - use swiftest_classes, only : swiftest_parameters implicit none class(symba_pl), intent(inout) :: self !! SyMBA massive body object class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters @@ -611,16 +357,6 @@ module subroutine symba_util_final_encounter_list(self) type(symba_encounter), intent(inout) :: self !! SyMBA encounter list object end subroutine symba_util_final_encounter_list - module subroutine symba_util_final_kin(self) - implicit none - type(symba_kinship), intent(inout) :: self !! SyMBA kinship object - end subroutine symba_util_final_kin - - module subroutine symba_util_final_merger(self) - implicit none - type(symba_merger), intent(inout) :: self !! SyMBA merger object - end subroutine symba_util_final_merger - module subroutine symba_util_final_pl(self) implicit none type(symba_pl), intent(inout) :: self !! SyMBA massive body object @@ -637,42 +373,15 @@ module subroutine symba_util_final_tp(self) end subroutine symba_util_final_tp module subroutine symba_util_peri_pl(self, system, param) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters implicit none class(symba_pl), intent(inout) :: self !! SyMBA massive body object class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters end subroutine symba_util_peri_pl - module subroutine symba_util_rearray_pl(self, system, param) - implicit none - class(symba_pl), intent(inout) :: self !! SyMBA massive body object - class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object - class(symba_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions - end subroutine symba_util_rearray_pl - - module subroutine symba_util_reset_kinship(self, idx) - implicit none - class(symba_pl), intent(inout) :: self !! SyMBA massive body object - integer(I4B), dimension(:), intent(in) :: idx !! Index array of bodies to reset - end subroutine symba_util_reset_kinship end interface - interface util_resize - module subroutine symba_util_resize_arr_kin(arr, nnew) - implicit none - type(symba_kinship), dimension(:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size - end subroutine symba_util_resize_arr_kin - end interface - interface - module subroutine symba_util_resize_merger(self, nnew) - implicit none - class(symba_merger), intent(inout) :: self !! SyMBA merger list object - integer(I4B), intent(in) :: nnew !! New size neded - end subroutine symba_util_resize_merger - module subroutine symba_util_resize_pl(self, nnew) implicit none class(symba_pl), intent(inout) :: self !! SyMBA massive body object @@ -700,15 +409,6 @@ module subroutine symba_util_sort_tp(self, sortby, ascending) end subroutine symba_util_sort_tp end interface - interface util_sort_rearrange - module subroutine symba_util_sort_rearrange_arr_kin(arr, ind, n) - implicit none - type(symba_kinship), dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange - end subroutine symba_util_sort_rearrange_arr_kin - end interface util_sort_rearrange - interface module subroutine symba_util_sort_rearrange_pl(self, ind) implicit none @@ -723,19 +423,8 @@ module subroutine symba_util_sort_rearrange_tp(self, ind) end subroutine symba_util_sort_rearrange_tp end interface - interface util_spill - 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 @@ -744,7 +433,7 @@ module subroutine symba_util_spill_pl(self, discards, lspill_list, ldestructive) end subroutine symba_util_spill_pl module subroutine symba_util_spill_encounter_list(self, discards, lspill_list, ldestructive) - use encounter_classes, only : encounter_list + use encounter, only : encounter_list implicit none class(symba_encounter), intent(inout) :: self !! SyMBA pl-tp encounter list class(encounter_list), intent(inout) :: discards !! Discarded object @@ -753,7 +442,6 @@ module subroutine symba_util_spill_encounter_list(self, discards, lspill_list, l end subroutine symba_util_spill_encounter_list 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 @@ -762,4 +450,4 @@ module subroutine symba_util_spill_tp(self, discards, lspill_list, ldestructive) end subroutine symba_util_spill_tp end interface -end module symba_classes \ No newline at end of file +end module symba \ No newline at end of file diff --git a/src/modules/walltime.f90 b/src/modules/walltime.f90 new file mode 100644 index 000000000..6ccce25b1 --- /dev/null +++ b/src/modules/walltime.f90 @@ -0,0 +1,76 @@ +!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh +!! This file is part of Swiftest. +!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License +!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. +!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty +!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. +!! You should have received a copy of the GNU General Public License along with Swiftest. +!! If not, see: https://www.gnu.org/licenses. + +module walltime + !! author: David A. Minton + !! + !! Classes and methods used to compute elasped wall time + use globals + use base + implicit none + public + + integer(I4B) :: INTERACTION_TIMER_CADENCE = 1000 !! Minimum number of steps to wait before timing an interaction loop in ADAPTIVE mode + character(len=*), parameter :: INTERACTION_TIMER_LOG_OUT = "interaction_timer.log" !! Name of log file for recording results of interaction loop timing + character(len=*), parameter :: ENCOUNTER_PLPL_TIMER_LOG_OUT = "encounter_check_plpl_timer.log" !! Name of log file for recording results of encounter check method timing + character(len=*), parameter :: ENCOUNTER_PLTP_TIMER_LOG_OUT = "encounter_check_pltp_timer.log" !! Name of log file for recording results of encounter check method timing + + type :: walltimer + integer(I8B) :: count_rate !! Rate at wich the clock ticks + integer(I8B) :: count_max !! Maximum value of the clock ticker + integer(I8B) :: count_start_main !! Value of the clock ticker at when the timer is first called + integer(I8B) :: count_start_step !! Value of the clock ticker at the start of a timed step + integer(I8B) :: count_stop_step !! Value of the clock ticker at the end of a timed step + integer(I8B) :: count_pause !! Value of the clock ticker at the end of a timed step + real(DP) :: wall_step !! Value of the step elapsed time + real(DP) :: wall_main !! Value of the main clock elapsed time + real(DP) :: wall_per_substep !! Value of time per substep + logical :: main_is_started = .false. !! Logical flag indicating whether or not the main timer has been reset or not + logical :: is_paused = .false. !! Logical flag indicating whether or not the timer is paused + + contains + procedure :: reset => walltime_reset !! Resets the clock ticker, settting main_start to the current ticker value + procedure :: start => walltime_start !! Starts or resumes the step timer + procedure :: start_main => walltime_start_main !! Starts the main timer + procedure :: stop => walltime_stop !! Pauses the step timer + procedure :: report => walltime_report !! Prints the elapsed time information to the terminal + end type walltimer + + + interface + module subroutine walltime_report(self, message, unit, nsubsteps) + implicit none + class(walltimer), intent(inout) :: self !! Walltimer object + character(len=*), intent(in) :: message !! Message to prepend to the wall time terminal output + integer(I4B), intent(in) :: unit !! Output file unit for report text to be directed + integer(I4B), optional, intent(in) :: nsubsteps !! Number of substeps used to compute the time per step + end subroutine walltime_report + + module subroutine walltime_reset(self) + implicit none + class(walltimer), intent(inout) :: self !! Walltimer object + end subroutine walltime_reset + + module subroutine walltime_start(self) + implicit none + class(walltimer), intent(inout) :: self !! Walltimer object + end subroutine walltime_start + + module subroutine walltime_start_main(self) + implicit none + class(walltimer), intent(inout) :: self !! Walltimer object + end subroutine walltime_start_main + + module subroutine walltime_stop(self) + implicit none + class(walltimer), intent(inout) :: self !! Walltimer object + end subroutine walltime_stop + end interface + +end module walltime \ No newline at end of file diff --git a/src/modules/walltime_classes.f90 b/src/modules/walltime_classes.f90 deleted file mode 100644 index 536272b44..000000000 --- a/src/modules/walltime_classes.f90 +++ /dev/null @@ -1,134 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -module walltime_classes - !! author: David A. Minton - !! - !! Classes and methods used to compute elasped wall time - use swiftest_globals - use swiftest_classes, only : swiftest_parameters, swiftest_pl - implicit none - public - - integer(I4B) :: INTERACTION_TIMER_CADENCE = 1000 !! Minimum number of steps to wait before timing an interaction loop in ADAPTIVE mode - character(len=*), parameter :: INTERACTION_TIMER_LOG_OUT = "interaction_timer.log" !! Name of log file for recording results of interaction loop timing - character(len=*), parameter :: ENCOUNTER_PLPL_TIMER_LOG_OUT = "encounter_check_plpl_timer.log" !! Name of log file for recording results of encounter check method timing - character(len=*), parameter :: ENCOUNTER_PLTP_TIMER_LOG_OUT = "encounter_check_pltp_timer.log" !! Name of log file for recording results of encounter check method timing - - type :: walltimer - integer(I8B) :: count_rate !! Rate at wich the clock ticks - integer(I8B) :: count_max !! Maximum value of the clock ticker - integer(I8B) :: count_start_main !! Value of the clock ticker at when the timer is first called - integer(I8B) :: count_start_step !! Value of the clock ticker at the start of a timed step - integer(I8B) :: count_stop_step !! Value of the clock ticker at the end of a timed step - integer(I8B) :: count_pause !! Value of the clock ticker at the end of a timed step - real(DP) :: wall_step !! Value of the step elapsed time - real(DP) :: wall_main !! Value of the main clock elapsed time - real(DP) :: wall_per_substep !! Value of time per substep - logical :: main_is_started = .false. !! Logical flag indicating whether or not the main timer has been reset or not - logical :: is_paused = .false. !! Logical flag indicating whether or not the timer is paused - - contains - procedure :: reset => walltime_reset !! Resets the clock ticker, settting main_start to the current ticker value - procedure :: start => walltime_start !! Starts or resumes the step timer - procedure :: start_main => walltime_start_main !! Starts the main timer - procedure :: stop => walltime_stop !! Pauses the step timer - procedure :: report => walltime_report !! Prints the elapsed time information to the terminal - end type walltimer - - type, extends(walltimer) :: interaction_timer - character(len=STRMAX) :: loopname !! Stores the name of the loop being timed for logging purposes - character(len=NAMELEN) :: looptype !! Stores the type of loop (e.g. INTERACTION or ENCOUNTER) - integer(I8B) :: max_interactions = huge(1_I8B) !! Stores the number of pl-pl interactions that failed when attempting to flatten (e.g. out of memory). Adapting won't occur if ninteractions > max_interactions - integer(I8B) :: last_interactions = 0 !! Number of interactions that were computed last time. The timer is only run if there has been a change to the number of interactions - integer(I4B) :: step_counter = 0 !! Number of steps that have elapsed since the last timed loop - logical :: is_on = .false. !! The loop timer is currently active - integer(I4B) :: stage = 1 !! The stage of the loop timing (1 or 2) - logical :: stage1_is_advanced !! Logical flag indicating whether stage1 was done with a flat loop (.true.) or triangular loop (.false.) - integer(I8B) :: stage1_ninteractions !! Number of interactions computed during stage 1 - real(DP) :: stage1_metric !! Metric used to judge the performance of a timed loop (e.g. (count_finish_step - count_start_step) / ninteractions) - real(DP) :: stage2_metric !! Metric used to judge the performance of a timed loop (e.g. (count_finish_step - count_start_step) / ninteractions) - contains - procedure :: adapt => walltime_interaction_adapt !! Runs the interaction loop adaptation algorithm on an interaction loop - procedure :: check => walltime_interaction_check !! Checks whether or not the loop should be timed and starts the timer if the conditions for starting are met - procedure :: flip => walltime_interaction_flip_loop_style !! Flips the interaction loop style from FLAT to TRIANGULAR or vice vers - procedure :: time_this_loop => walltime_interaction_time_this_loop !! Starts the interaction loop timer - end type interaction_timer - - interface - module subroutine walltime_report(self, message, unit, nsubsteps) - implicit none - class(walltimer), intent(inout) :: self !! Walltimer object - character(len=*), intent(in) :: message !! Message to prepend to the wall time terminal output - integer(I4B), intent(in) :: unit !! Output file unit for report text to be directed - integer(I4B), optional, intent(in) :: nsubsteps !! Number of substeps used to compute the time per step - end subroutine walltime_report - - module subroutine walltime_reset(self) - implicit none - class(walltimer), intent(inout) :: self !! Walltimer object - end subroutine walltime_reset - - module subroutine walltime_start(self) - implicit none - class(walltimer), intent(inout) :: self !! Walltimer object - end subroutine walltime_start - - module subroutine walltime_start_main(self) - implicit none - class(walltimer), intent(inout) :: self !! Walltimer object - end subroutine walltime_start_main - - module subroutine walltime_stop(self) - implicit none - class(walltimer), intent(inout) :: self !! Walltimer object - end subroutine walltime_stop - end interface - - interface - module subroutine walltime_interaction_adapt(self, param, ninteractions, pl) - use swiftest_classes, only : swiftest_parameters - implicit none - class(interaction_timer), intent(inout) :: self !! Interaction loop timer object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - integer(I8B), intent(in) :: ninteractions !! Current number of interactions (used to normalize the timed loop and to determine if number of interactions has changed since the last timing - class(swiftest_pl), intent(inout), optional :: pl !! Swiftest massive body object - end subroutine walltime_interaction_adapt - - module function walltime_interaction_check(self, param, ninteractions) result(ltimeit) - use swiftest_classes, only : swiftest_parameters - implicit none - class(interaction_timer), intent(inout) :: self !! Interaction loop timer object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - integer(I8B), intent(in) :: ninteractions !! Current number of interactions (used to normalize the timed loop and to determine if number of interactions has changed since the last timing - logical :: ltimeit !! Logical flag indicating whether this loop should be timed or not - end function walltime_interaction_check - - module subroutine walltime_interaction_flip_loop_style(self, param, pl) - use swiftest_classes, only : swiftest_parameters, swiftest_pl - implicit none - class(interaction_timer), intent(inout) :: self !! Interaction loop timer object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - class(swiftest_pl), intent(inout), optional :: pl !! Swiftest massive body object - end subroutine walltime_interaction_flip_loop_style - - module subroutine walltime_interaction_time_this_loop(self, param, ninteractions, pl) - use swiftest_classes, only : swiftest_parameters, swiftest_pl - implicit none - class(interaction_timer), intent(inout) :: self !! Interaction loop timer object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - integer(I8B), intent(in) :: ninteractions !! Current number of interactions (used to normalize the timed loop) - class(swiftest_pl), intent(inout), optional :: pl !! Swiftest massive body object - end subroutine walltime_interaction_time_this_loop - - end interface - - - -end module walltime_classes \ No newline at end of file diff --git a/src/modules/whm_classes.f90 b/src/modules/whm.f90 similarity index 86% rename from src/modules/whm_classes.f90 rename to src/modules/whm.f90 index 100e606c4..7b09bbfbc 100644 --- a/src/modules/whm_classes.f90 +++ b/src/modules/whm.f90 @@ -7,27 +7,20 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -module whm_classes +module whm !! author: David A. Minton !! !! Definition of classes and methods specific to the Democratic Heliocentric Method !! Partially adapted from David E. Kaufmann's Swifter module: module_whm.f90 - use swiftest_globals - use swiftest_classes, only : swiftest_cb, swiftest_pl, swiftest_tp, swiftest_nbody_system + use swiftest implicit none public - !******************************************************************************************************************************** - ! whm_cb class definitions and method interfaces - !******************************************************************************************************************************* !> Swiftest central body particle class type, extends(swiftest_cb) :: whm_cb contains end type whm_cb - !******************************************************************************************************************************** - ! whm_pl class definitions and method interfaces - !******************************************************************************************************************************* !> WHM massive body particle class type, extends(swiftest_pl) :: whm_pl @@ -61,9 +54,6 @@ module whm_classes final :: whm_util_final_pl !! Finalizes the WHM massive body object - deallocates all allocatables end type whm_pl - !******************************************************************************************************************************** - ! whm_tp class definitions and method interfaces - !******************************************************************************************************************************* !! WHM test particle class type, extends(swiftest_tp) :: whm_tp @@ -78,9 +68,6 @@ module whm_classes final :: whm_util_final_tp !! Finalizes the WHM test particle object - deallocates all allocatables end type whm_tp - !******************************************************************************************************************************** - ! whm_nbody_system class definitions and method interfaces - !******************************************************************************************************************************** !> An abstract class for the WHM integrator nbody system type, extends(swiftest_nbody_system) :: whm_nbody_system contains @@ -92,28 +79,24 @@ module whm_classes interface module subroutine whm_coord_h2j_pl(self, cb) - use swiftest_classes, only : swiftest_cb implicit none class(whm_pl), intent(inout) :: self !! WHM massive body particle data structure class(swiftest_cb), intent(inout) :: cb !! Swiftest central body particle data structuree end subroutine whm_coord_h2j_pl module subroutine whm_coord_j2h_pl(self, cb) - use swiftest_classes, only : swiftest_cb implicit none class(whm_pl), intent(inout) :: self !! WHM massive body particle data structure class(swiftest_cb), intent(inout) :: cb !! Swiftest central body particle data structuree end subroutine whm_coord_j2h_pl module subroutine whm_coord_vh2vj_pl(self, cb) - use swiftest_classes, only : swiftest_cb implicit none class(whm_pl), intent(inout) :: self !! WHM massive body particle data structure class(swiftest_cb), intent(inout) :: cb !! Swiftest central body particle data structuree end subroutine whm_coord_vh2vj_pl module subroutine whm_drift_pl(self, system, param, dt) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters implicit none class(whm_pl), intent(inout) :: self !! WHM massive body particle data structure class(swiftest_nbody_system), intent(inout) :: system !! WHM nbody system object @@ -123,7 +106,6 @@ end subroutine whm_drift_pl !> Get heliocentric accelration of massive bodies module subroutine whm_kick_getacch_pl(self, system, param, t, lbeg) - use swiftest_classes, only : swiftest_cb, swiftest_parameters implicit none class(whm_pl), intent(inout) :: self !! WHM massive body particle data structure class(swiftest_nbody_system), intent(inout) :: system !! WHM nbody system object @@ -134,7 +116,6 @@ end subroutine whm_kick_getacch_pl !> Get heliocentric accelration of the test particle module subroutine whm_kick_getacch_tp(self, system, param, t, lbeg) - use swiftest_classes, only : swiftest_cb, swiftest_parameters implicit none class(whm_tp), intent(inout) :: self !! WHM test particle data structure class(swiftest_nbody_system), intent(inout) :: system !! WHM nbody system object @@ -144,7 +125,6 @@ module subroutine whm_kick_getacch_tp(self, system, param, t, lbeg) end subroutine whm_kick_getacch_tp module subroutine whm_kick_vh_pl(self, system, param, t, dt, lbeg) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters implicit none class(whm_pl), intent(inout) :: self !! WHM massive body object class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object @@ -155,7 +135,6 @@ module subroutine whm_kick_vh_pl(self, system, param, t, dt, lbeg) end subroutine whm_kick_vh_pl module subroutine whm_kick_vh_tp(self, system, param, t, dt, lbeg) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters implicit none class(whm_tp), intent(inout) :: self !! WHM test particle object class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object @@ -166,21 +145,18 @@ module subroutine whm_kick_vh_tp(self, system, param, t, dt, lbeg) end subroutine whm_kick_vh_tp pure module subroutine whm_gr_kick_getacch_pl(self, param) - use swiftest_classes, only : swiftest_cb, swiftest_parameters implicit none class(whm_pl), intent(inout) :: self !! WHM massive body particle data structure class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters end subroutine whm_gr_kick_getacch_pl pure module subroutine whm_gr_kick_getacch_tp(self, param) - use swiftest_classes, only : swiftest_cb, swiftest_parameters implicit none class(whm_tp), intent(inout) :: self !! WHM test particle data structure class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters end subroutine whm_gr_kick_getacch_tp pure module subroutine whm_gr_p4_pl(self, system, param, dt) - use swiftest_classes, only : swiftest_parameters implicit none class(whm_pl), intent(inout) :: self !! WHM massive body object class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system @@ -189,7 +165,6 @@ pure module subroutine whm_gr_p4_pl(self, system, param, dt) end subroutine whm_gr_p4_pl pure module subroutine whm_gr_p4_tp(self, system, param, dt) - use swiftest_classes, only : swiftest_parameters implicit none class(whm_tp), intent(inout) :: self !! WHM test particle object class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system @@ -199,7 +174,6 @@ end subroutine whm_gr_p4_tp !> Reads WHM massive body object in from file module subroutine whm_setup_pl(self, n, param) - use swiftest_classes, only : swiftest_parameters implicit none class(whm_pl), intent(inout) :: self !! WHM massive body objectobject integer(I4B), intent(in) :: n !! Number of particles to allocate space for @@ -207,14 +181,12 @@ module subroutine whm_setup_pl(self, n, param) end subroutine whm_setup_pl module subroutine whm_setup_initialize_system(self, param) - use swiftest_classes, only : swiftest_parameters implicit none class(whm_nbody_system), intent(inout) :: self !! WHM nbody system object class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters end subroutine whm_setup_initialize_system module subroutine whm_step_pl(self, system, param, t, dt) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters implicit none class(whm_pl), intent(inout) :: self !! WHM massive body object class(swiftest_nbody_system), intent(inout) :: system !! Swiftest system object @@ -224,7 +196,6 @@ module subroutine whm_step_pl(self, system, param, t, dt) end subroutine whm_step_pl module subroutine whm_step_system(self, param, t, dt) - use swiftest_classes, only : swiftest_parameters implicit none class(whm_nbody_system), intent(inout) :: self !! WHM system object class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters @@ -233,7 +204,6 @@ module subroutine whm_step_system(self, param, t, dt) end subroutine whm_step_system module subroutine whm_step_tp(self, system, param, t, dt) - use swiftest_classes, only : swiftest_nbody_system, swiftest_parameters implicit none class(whm_tp), intent(inout) :: self !! WHM test particle data structure class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object @@ -243,7 +213,6 @@ module subroutine whm_step_tp(self, system, param, t, dt) end subroutine whm_step_tp module subroutine whm_util_append_pl(self, source, lsource_mask) - use swiftest_classes, only : swiftest_body implicit none class(whm_pl), intent(inout) :: self !! WHM massive body object class(swiftest_body), intent(in) :: source !! Source object to append @@ -271,16 +240,14 @@ module subroutine whm_util_final_tp(self) end subroutine whm_util_final_tp module subroutine whm_util_spill_pl(self, discards, lspill_list, ldestructive) - use swiftest_classes, only : swiftest_body implicit none class(whm_pl), intent(inout) :: self !! WHM massive body object - class(swiftest_body), intent(inout) :: discards !! Discarded 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 whm_util_spill_pl module subroutine whm_util_fill_pl(self, inserts, lfill_list) - use swiftest_classes, only : swiftest_body implicit none class(whm_pl), intent(inout) :: self !! WHM massive body object class(swiftest_body), intent(in) :: inserts !! inserted object @@ -299,7 +266,6 @@ module subroutine whm_util_set_ir3j(self) end subroutine whm_util_set_ir3j module subroutine whm_util_set_mu_eta_pl(self, cb) - use swiftest_classes, only : swiftest_cb implicit none class(whm_pl), intent(inout) :: self !! WHM massive body object class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object @@ -319,4 +285,4 @@ module subroutine whm_util_sort_rearrange_pl(self, ind) end subroutine whm_util_sort_rearrange_pl end interface -end module whm_classes +end module whm diff --git a/src/netcdf/netcdf.f90 b/src/netcdf/netcdf.f90 deleted file mode 100644 index eaf11ddd4..000000000 --- a/src/netcdf/netcdf.f90 +++ /dev/null @@ -1,1290 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule (swiftest_classes) s_netcdf - use swiftest - use netcdf -contains - - module subroutine check(status, call_identifier) - !! author: Carlisle A. Wishard, Dana Singh, and David A. Minton - !! - !! Checks the status of all NetCDF operations to catch errors - implicit none - ! Arguments - integer, intent (in) :: status !! The status code returned by a NetCDF function - character(len=*), intent(in), optional :: call_identifier !! String that indicates which calling function caused the error for diagnostic purposes - - if(status /= nf90_noerr) then - if (present(call_identifier)) write(*,*) "NetCDF error in ",trim(call_identifier) - write(*,*) trim(nf90_strerror(status)) - call util_exit(FAILURE) - end if - - return - end subroutine check - - - module subroutine netcdf_close(self) - !! author: Carlisle A. Wishard, Dana Singh, and David A. Minton - !! - !! Closes a NetCDF file - implicit none - ! Arguments - class(netcdf_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset - - call check( nf90_close(self%id), "netcdf_close" ) - - return - end subroutine netcdf_close - - - module subroutine netcdf_flush(self, param) - !! author: David A. Minton - !! - !! Flushes the current buffer to disk by closing and re-opening the file. - !! - implicit none - ! Arguments - class(netcdf_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - - call self%close() - call self%open(param) - - return - end subroutine netcdf_flush - - - module function netcdf_get_old_t_final_system(self, param) result(old_t_final) - !! author: David A. Minton - !! - !! Validates the dump file to check whether the dump file initial conditions duplicate the last frame of the netcdf output. - !! - implicit none - ! Arguments - class(swiftest_nbody_system), intent(inout) :: self - class(swiftest_parameters), intent(inout) :: param - ! Result - real(DP) :: old_t_final - ! Internals - integer(I4B) :: itmax, idmax - real(DP), dimension(:), allocatable :: vals - real(DP), dimension(1) :: rtemp - real(DP), dimension(NDIM) :: rot0, Ip0, Lnow - real(DP) :: KE_orb_orig, KE_spin_orig, PE_orig - - associate (nc => param%system_history%nc) - call nc%open(param) - call check( nf90_inquire_dimension(nc%id, nc%time_dimid, len=itmax), "netcdf_get_old_t_final_system time_dimid" ) - call check( nf90_inquire_dimension(nc%id, nc%name_dimid, len=idmax), "netcdf_get_old_t_final_system name_dimid" ) - allocate(vals(idmax)) - call check( nf90_get_var(nc%id, nc%time_varid, rtemp, start=[1], count=[1]), "netcdf_get_old_t_final_system time_varid" ) - - !old_t_final = rtemp(1) - old_t_final = param%t0 ! For NetCDF it is safe to overwrite the final t value on a restart - - if (param%lenergy) then - call check( nf90_get_var(nc%id, nc%KE_orb_varid, rtemp, start=[1], count=[1]), "netcdf_get_old_t_final_system KE_orb_varid" ) - KE_orb_orig = rtemp(1) - - call check( nf90_get_var(nc%id, nc%KE_spin_varid, rtemp, start=[1], count=[1]), "netcdf_get_old_t_final_system KE_spin_varid" ) - KE_spin_orig = rtemp(1) - - call check( nf90_get_var(nc%id, nc%PE_varid, rtemp, start=[1], count=[1]), "netcdf_get_old_t_final_system PE_varid" ) - PE_orig = rtemp(1) - - call check( nf90_get_var(nc%id, nc%Ecollisions_varid, self%Ecollisions, start=[1]), "netcdf_get_old_t_final_system Ecollisions_varid" ) - call check( nf90_get_var(nc%id, nc%Euntracked_varid, self%Euntracked, start=[1]), "netcdf_get_old_t_final_system Euntracked_varid" ) - - self%Eorbit_orig = KE_orb_orig + KE_spin_orig + PE_orig + self%Ecollisions + self%Euntracked - - call check( nf90_get_var(nc%id, nc%L_orb_varid, self%Lorbit_orig(:), start=[1,1], count=[NDIM,1]), "netcdf_get_old_t_final_system L_orb_varid" ) - call check( nf90_get_var(nc%id, nc%Lspin_varid, self%Lspin_orig(:), start=[1,1], count=[NDIM,1]), "netcdf_get_old_t_final_system Lspin_varid" ) - call check( nf90_get_var(nc%id, nc%L_escape_varid, self%Lescape(:), start=[1,1], count=[NDIM,1]), "netcdf_get_old_t_final_system L_escape_varid" ) - - self%Ltot_orig(:) = self%Lorbit_orig(:) + self%Lspin_orig(:) + self%Lescape(:) - - call check( nf90_get_var(nc%id, nc%Gmass_varid, vals, start=[1,1], count=[idmax,1]), "netcdf_get_old_t_final_system Gmass_varid" ) - call check( nf90_get_var(nc%id, nc%GMescape_varid, self%GMescape, start=[1]), "netcdf_get_old_t_final_system GMescape_varid" ) - self%GMtot_orig = vals(1) + sum(vals(2:idmax), vals(2:idmax) == vals(2:idmax)) + self%GMescape - - select type(cb => self%cb) - class is (symba_cb) - cb%GM0 = vals(1) - cb%dGM = cb%Gmass - cb%GM0 - - call check( nf90_get_var(nc%id, nc%radius_varid, rtemp, start=[1,1], count=[1,1]), "netcdf_get_old_t_final_system radius_varid" ) - cb%R0 = rtemp(1) - - if (param%lrotation) then - - call check( nf90_get_var(nc%id, nc%rot_varid, rot0, start=[1,1,1], count=[NDIM,1,1]), "netcdf_get_old_t_final_system rot_varid" ) - call check( nf90_get_var(nc%id, nc%Ip_varid, Ip0, start=[1,1,1], count=[NDIM,1,1]), "netcdf_get_old_t_final_system Ip_varid" ) - - cb%L0(:) = Ip0(3) * cb%GM0 * cb%R0**2 * rot0(:) - - Lnow(:) = cb%Ip(3) * cb%Gmass * cb%radius**2 * cb%rot(:) - cb%dL(:) = Lnow(:) - cb%L0(:) - end if - end select - - end if - - deallocate(vals) - end associate - - return - end function netcdf_get_old_t_final_system - - - module subroutine netcdf_initialize_output(self, param) - !! author: Carlisle A. Wishard, Dana Singh, and David A. Minton - !! - !! Initialize a NetCDF file system and defines all variables. - use, intrinsic :: ieee_arithmetic - implicit none - ! Arguments - class(netcdf_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - ! Internals - integer(I4B) :: nvar, varid, vartype - real(DP) :: dfill - real(SP) :: sfill - integer(I4B), parameter :: NO_FILL = 0 - logical :: fileExists - character(len=STRMAX) :: errmsg - integer(I4B) :: ndims - - associate(nc => self) - - dfill = ieee_value(dfill, IEEE_QUIET_NAN) - sfill = ieee_value(sfill, IEEE_QUIET_NAN) - - select case (param%out_type) - case("NETCDF_FLOAT") - nc%out_type = NF90_FLOAT - case("NETCDF_DOUBLE") - nc%out_type = NF90_DOUBLE - end select - - ! Check if the file exists, and if it does, delete it - inquire(file=nc%file_name, exist=fileExists) - if (fileExists) then - open(unit=LUN, file=nc%file_name, status="old", err=667, iomsg=errmsg) - close(unit=LUN, status="delete") - end if - - ! Create the file - call check( nf90_create(nc%file_name, NF90_NETCDF4, nc%id), "netcdf_initialize_output nf90_create" ) - - ! Dimensions - call check( nf90_def_dim(nc%id, nc%time_dimname, NF90_UNLIMITED, nc%time_dimid), "netcdf_initialize_output nf90_def_dim time_dimid" ) ! Simulation time dimension - call check( nf90_def_dim(nc%id, nc%space_dimname, NDIM, nc%space_dimid), "netcdf_initialize_output nf90_def_dim space_dimid" ) ! 3D space dimension - call check( nf90_def_dim(nc%id, nc%name_dimname, NF90_UNLIMITED, nc%name_dimid), "netcdf_initialize_output nf90_def_dim name_dimid" ) ! dimension to store particle id numbers - call check( nf90_def_dim(nc%id, nc%str_dimname, NAMELEN, nc%str_dimid), "netcdf_initialize_output nf90_def_dim str_dimid" ) ! Dimension for string variables (aka character arrays) - - ! Dimension coordinates - call check( nf90_def_var(nc%id, nc%time_dimname, nc%out_type, nc%time_dimid, nc%time_varid), "netcdf_initialize_output nf90_def_var time_varid" ) - call check( nf90_def_var(nc%id, nc%space_dimname, NF90_CHAR, nc%space_dimid, nc%space_varid), "netcdf_initialize_output nf90_def_var space_varid" ) - call check( nf90_def_var(nc%id, nc%name_dimname, NF90_CHAR, [nc%str_dimid, nc%name_dimid], nc%name_varid), "netcdf_initialize_output nf90_def_var name_varid" ) - - ! Variables - call check( nf90_def_var(nc%id, nc%id_varname, NF90_INT, nc%name_dimid, nc%id_varid), "netcdf_initialize_output nf90_def_var id_varid" ) - call check( nf90_def_var(nc%id, nc%npl_varname, NF90_INT, nc%time_dimid, nc%npl_varid), "netcdf_initialize_output nf90_def_var npl_varid" ) - call check( nf90_def_var(nc%id, nc%ntp_varname, NF90_INT, nc%time_dimid, nc%ntp_varid), "netcdf_initialize_output nf90_def_var ntp_varid" ) - if (param%integrator == SYMBA) call check( nf90_def_var(nc%id, nc%nplm_varname, NF90_INT, nc%time_dimid, nc%nplm_varid), "netcdf_initialize_output nf90_def_var nplm_varid" ) - call check( nf90_def_var(nc%id, nc%ptype_varname, NF90_CHAR, [nc%str_dimid, nc%name_dimid], nc%ptype_varid), "netcdf_initialize_output nf90_def_var ptype_varid" ) - - if ((param%out_form == "XV") .or. (param%out_form == "XVEL")) then - call check( nf90_def_var(nc%id, nc%rh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%rh_varid), "netcdf_initialize_output nf90_def_var rh_varid" ) - call check( nf90_def_var(nc%id, nc%vh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%vh_varid), "netcdf_initialize_output nf90_def_var vh_varid" ) - - !! When GR is enabled, we need to save the pseudovelocity vectors in addition to the true heliocentric velocity vectors, otherwise - !! we cannnot expect bit-identical runs from restarted runs with GR enabled due to floating point errors during the conversion. - if (param%lgr) then - call check( nf90_def_var(nc%id, nc%gr_pseudo_vh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%gr_pseudo_vh_varid), "netcdf_initialize_output nf90_def_var gr_psuedo_vh_varid" ) - nc%lpseudo_vel_exists = .true. - end if - - end if - - if ((param%out_form == "EL") .or. (param%out_form == "XVEL")) then - call check( nf90_def_var(nc%id, nc%a_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%a_varid), "netcdf_initialize_output nf90_def_var a_varid" ) - call check( nf90_def_var(nc%id, nc%e_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%e_varid), "netcdf_initialize_output nf90_def_var e_varid" ) - call check( nf90_def_var(nc%id, nc%inc_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%inc_varid), "netcdf_initialize_output nf90_def_var inc_varid" ) - call check( nf90_def_var(nc%id, nc%capom_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%capom_varid), "netcdf_initialize_output nf90_def_var capom_varid" ) - call check( nf90_def_var(nc%id, nc%omega_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%omega_varid), "netcdf_initialize_output nf90_def_var omega_varid" ) - call check( nf90_def_var(nc%id, nc%capm_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%capm_varid), "netcdf_initialize_output nf90_def_var capm_varid" ) - call check( nf90_def_var(nc%id, nc%varpi_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%varpi_varid), "netcdf_initialize_output nf90_def_var varpi_varid" ) - call check( nf90_def_var(nc%id, nc%lam_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%lam_varid), "netcdf_initialize_output nf90_def_var lam_varid" ) - call check( nf90_def_var(nc%id, nc%f_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%f_varid), "netcdf_initialize_output nf90_def_var f_varid" ) - call check( nf90_def_var(nc%id, nc%cape_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%cape_varid), "netcdf_initialize_output nf90_def_var cape_varid" ) - end if - - call check( nf90_def_var(nc%id, nc%gmass_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%Gmass_varid), "netcdf_initialize_output nf90_def_var Gmass_varid" ) - - if (param%lrhill_present) then - call check( nf90_def_var(nc%id, nc%rhill_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%rhill_varid), "netcdf_initialize_output nf90_def_var rhill_varid" ) - end if - - if (param%lclose) then - call check( nf90_def_var(nc%id, nc%radius_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%radius_varid), "netcdf_initialize_output nf90_def_var radius_varid" ) - - call check( nf90_def_var(nc%id, nc%origin_time_varname, nc%out_type, nc%name_dimid, nc%origin_time_varid), "netcdf_initialize_output nf90_def_var origin_time_varid" ) - call check( nf90_def_var(nc%id, nc%origin_type_varname, NF90_CHAR, [nc%str_dimid, nc%name_dimid], & - nc%origin_type_varid), "netcdf_initialize_output nf90_create" ) - call check( nf90_def_var(nc%id, nc%origin_rh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid], nc%origin_rh_varid), "netcdf_initialize_output nf90_def_var origin_rh_varid" ) - call check( nf90_def_var(nc%id, nc%origin_vh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid], nc%origin_vh_varid), "netcdf_initialize_output nf90_def_var origin_vh_varid" ) - - call check( nf90_def_var(nc%id, nc%collision_id_varname, NF90_INT, nc%name_dimid, nc%collision_id_varid), "netcdf_initialize_output nf90_def_var collision_id_varid" ) - call check( nf90_def_var(nc%id, nc%discard_time_varname, nc%out_type, nc%name_dimid, nc%discard_time_varid), "netcdf_initialize_output nf90_def_var discard_time_varid" ) - call check( nf90_def_var(nc%id, nc%discard_rh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid], nc%discard_rh_varid), "netcdf_initialize_output nf90_def_var discard_rh_varid" ) - call check( nf90_def_var(nc%id, nc%discard_vh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid], nc%discard_vh_varid), "netcdf_initialize_output nf90_def_var discard_vh_varid" ) - call check( nf90_def_var(nc%id, nc%discard_body_id_varname, NF90_INT, nc%name_dimid, nc%discard_body_id_varid), "netcdf_initialize_output nf90_def_var discard_body_id_varid" ) - end if - - if (param%lrotation) then - call check( nf90_def_var(nc%id, nc%Ip_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%Ip_varid), "netcdf_initialize_output nf90_def_var Ip_varid" ) - call check( nf90_def_var(nc%id, nc%rot_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%rot_varid), "netcdf_initialize_output nf90_def_var rot_varid" ) - end if - - ! if (param%ltides) then - ! call check( nf90_def_var(nc%id, nc%k2_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%k2_varid), "netcdf_initialize_output nf90_def_var k2_varid" ) - ! call check( nf90_def_var(nc%id, nc%q_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%Q_varid), "netcdf_initialize_output nf90_def_var Q_varid" ) - ! end if - - if (param%lenergy) then - call check( nf90_def_var(nc%id, nc%ke_orb_varname, nc%out_type, nc%time_dimid, nc%KE_orb_varid), "netcdf_initialize_output nf90_def_var KE_orb_varid" ) - call check( nf90_def_var(nc%id, nc%ke_spin_varname, nc%out_type, nc%time_dimid, nc%KE_spin_varid), "netcdf_initialize_output nf90_def_var KE_spin_varid" ) - call check( nf90_def_var(nc%id, nc%pe_varname, nc%out_type, nc%time_dimid, nc%PE_varid), "netcdf_initialize_output nf90_def_var PE_varid" ) - call check( nf90_def_var(nc%id, nc%L_orb_varname, nc%out_type, [nc%space_dimid, nc%time_dimid], nc%L_orb_varid), "netcdf_initialize_output nf90_def_var L_orb_varid" ) - call check( nf90_def_var(nc%id, nc%Lspin_varname, nc%out_type, [nc%space_dimid, nc%time_dimid], nc%Lspin_varid), "netcdf_initialize_output nf90_def_var Lspin_varid" ) - call check( nf90_def_var(nc%id, nc%L_escape_varname, nc%out_type, [nc%space_dimid, nc%time_dimid], nc%L_escape_varid), "netcdf_initialize_output nf90_def_var L_escape_varid" ) - call check( nf90_def_var(nc%id, nc%Ecollisions_varname, nc%out_type, nc%time_dimid, nc%Ecollisions_varid), "netcdf_initialize_output nf90_def_var Ecollisions_varid" ) - call check( nf90_def_var(nc%id, nc%Euntracked_varname, nc%out_type, nc%time_dimid, nc%Euntracked_varid), "netcdf_initialize_output nf90_def_var Euntracked_varid" ) - call check( nf90_def_var(nc%id, nc%GMescape_varname, nc%out_type, nc%time_dimid, nc%GMescape_varid), "netcdf_initialize_output nf90_def_var GMescape_varid" ) - end if - - call check( nf90_def_var(nc%id, nc%j2rp2_varname, nc%out_type, nc%time_dimid, nc%j2rp2_varid), "netcdf_initialize_output nf90_def_var j2rp2_varid" ) - call check( nf90_def_var(nc%id, nc%j4rp4_varname, nc%out_type, nc%time_dimid, nc%j4rp4_varid), "netcdf_initialize_output nf90_def_var j4rp4_varid" ) - - - ! Set fill mode to NaN for all variables - call check( nf90_inquire(nc%id, nVariables=nvar), "netcdf_initialize_output nf90_inquire nVariables" ) - do varid = 1, nvar - call check( nf90_inquire_variable(nc%id, varid, xtype=vartype, ndims=ndims), "netcdf_initialize_output nf90_inquire_variable" ) - select case(vartype) - case(NF90_INT) - call check( nf90_def_var_fill(nc%id, varid, NO_FILL, NF90_FILL_INT), "netcdf_initialize_output nf90_def_var_fill NF90_INT" ) - case(NF90_FLOAT) - call check( nf90_def_var_fill(nc%id, varid, NO_FILL, sfill), "netcdf_initialize_output nf90_def_var_fill NF90_FLOAT" ) - case(NF90_DOUBLE) - call check( nf90_def_var_fill(nc%id, varid, NO_FILL, dfill), "netcdf_initialize_output nf90_def_var_fill NF90_DOUBLE" ) - case(NF90_CHAR) - call check( nf90_def_var_fill(nc%id, varid, NO_FILL, 0), "netcdf_initialize_output nf90_def_var_fill NF90_CHAR" ) - end select - end do - - ! Set special fill mode for discard time so that we can make use of it for non-discarded bodies. - select case (vartype) - case(NF90_FLOAT) - call check( nf90_def_var_fill(nc%id, nc%discard_time_varid, NO_FILL, huge(1.0_SP)), "netcdf_initialize_output nf90_def_var_fill discard_time NF90_FLOAT" ) - case(NF90_DOUBLE) - call check( nf90_def_var_fill(nc%id, nc%discard_time_varid, NO_FILL, huge(1.0_DP)), "netcdf_initialize_output nf90_def_var_fill discard_time NF90_DOUBLE" ) - end select - - ! Take the file out of define mode - call check( nf90_enddef(nc%id), "netcdf_initialize_output nf90_enddef" ) - - ! Add in the space dimension coordinates - call check( nf90_put_var(nc%id, nc%space_varid, nc%space_coords, start=[1], count=[NDIM]), "netcdf_initialize_output nf90_put_var space" ) - - end associate - return - - 667 continue - write(*,*) "Error creating NetCDF output file. " // trim(adjustl(errmsg)) - call util_exit(FAILURE) - end subroutine netcdf_initialize_output - - - module subroutine netcdf_open(self, param, readonly) - !! author: Carlisle A. Wishard, Dana Singh, and David A. Minton - !! - !! Opens a NetCDF file and does the variable inquiries to activate variable ids - implicit none - ! Arguments - class(netcdf_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - logical, optional, intent(in) :: readonly !! Logical flag indicating that this should be open read only - ! Internals - integer(I4B) :: mode, status - character(len=STRMAX) :: errmsg - - mode = NF90_WRITE - if (present(readonly)) then - if (readonly) mode = NF90_NOWRITE - end if - - associate(nc => self) - - write(errmsg,*) "netcdf_open nf90_open ",trim(adjustl(nc%file_name)) - call check( nf90_open(nc%file_name, mode, nc%id), errmsg) - - ! Dimensions - call check( nf90_inq_dimid(nc%id, nc%time_dimname, nc%time_dimid), "netcdf_open nf90_inq_dimid time_dimid" ) - call check( nf90_inq_dimid(nc%id, nc%space_dimname, nc%space_dimid), "netcdf_open nf90_inq_dimid space_dimid" ) - call check( nf90_inq_dimid(nc%id, nc%name_dimname, nc%name_dimid), "netcdf_open nf90_inq_dimid name_dimid" ) - call check( nf90_inq_dimid(nc%id, nc%str_dimname, nc%str_dimid), "netcdf_open nf90_inq_dimid str_dimid" ) - - ! Dimension coordinates - call check( nf90_inq_varid(nc%id, nc%time_dimname, nc%time_varid), "netcdf_open nf90_inq_varid time_varid" ) - call check( nf90_inq_varid(nc%id, nc%space_dimname, nc%space_varid), "netcdf_open nf90_inq_varid space_varid" ) - call check( nf90_inq_varid(nc%id, nc%name_dimname, nc%name_varid), "netcdf_open nf90_inq_varid name_varid" ) - - ! Required Variables - call check( nf90_inq_varid(nc%id, nc%id_varname, nc%id_varid), "netcdf_open nf90_inq_varid name_varid" ) - call check( nf90_inq_varid(nc%id, nc%gmass_varname, nc%Gmass_varid), "netcdf_open nf90_inq_varid Gmass_varid" ) - - if ((param%out_form == "XV") .or. (param%out_form == "XVEL")) then - call check( nf90_inq_varid(nc%id, nc%rh_varname, nc%rh_varid), "netcdf_open nf90_inq_varid rh_varid" ) - call check( nf90_inq_varid(nc%id, nc%vh_varname, nc%vh_varid), "netcdf_open nf90_inq_varid vh_varid" ) - - if (param%lgr) then - !! check if pseudovelocity vectors exist in this file. If they are, set the correct flag so we know whe should not do the conversion. - status = nf90_inq_varid(nc%id, nc%gr_pseudo_vh_varname, nc%gr_pseudo_vh_varid) - nc%lpseudo_vel_exists = (status == nf90_noerr) - if (param%lrestart .and. .not.nc%lpseudo_vel_exists) then - write(*,*) "Warning! Pseudovelocity not found in input file for GR enabled run. If this is a restarted run, bit-identical trajectories are not guarunteed!" - end if - - end if - end if - - if ((param%out_form == "EL") .or. (param%out_form == "XVEL")) then - call check( nf90_inq_varid(nc%id, nc%a_varname, nc%a_varid), "netcdf_open nf90_inq_varid a_varid" ) - call check( nf90_inq_varid(nc%id, nc%e_varname, nc%e_varid), "netcdf_open nf90_inq_varid e_varid" ) - call check( nf90_inq_varid(nc%id, nc%inc_varname, nc%inc_varid), "netcdf_open nf90_inq_varid inc_varid" ) - call check( nf90_inq_varid(nc%id, nc%capom_varname, nc%capom_varid), "netcdf_open nf90_inq_varid capom_varid" ) - call check( nf90_inq_varid(nc%id, nc%omega_varname, nc%omega_varid), "netcdf_open nf90_inq_varid omega_varid" ) - call check( nf90_inq_varid(nc%id, nc%capm_varname, nc%capm_varid), "netcdf_open nf90_inq_varid capm_varid" ) - end if - - if (param%lclose) then - call check( nf90_inq_varid(nc%id, nc%radius_varname, nc%radius_varid), "netcdf_open nf90_inq_varid radius_varid" ) - end if - - if (param%lrotation) then - call check( nf90_inq_varid(nc%id, nc%Ip_varname, nc%Ip_varid), "netcdf_open nf90_inq_varid Ip_varid" ) - call check( nf90_inq_varid(nc%id, nc%rot_varname, nc%rot_varid), "netcdf_open nf90_inq_varid rot_varid" ) - end if - - ! if (param%ltides) then - ! call check( nf90_inq_varid(nc%id, nc%k2_varname, nc%k2_varid), "netcdf_open nf90_inq_varid k2_varid" ) - ! call check( nf90_inq_varid(nc%id, nc%q_varname, nc%Q_varid), "netcdf_open nf90_inq_varid Q_varid" ) - ! end if - - ! Optional Variables - if (param%lrhill_present) then - status = nf90_inq_varid(nc%id, nc%rhill_varname, nc%rhill_varid) - if (status /= nf90_noerr) write(*,*) "Warning! RHILL variable not set in input file. Calculating." - end if - - ! Optional variables The User Doesn't Need to Know About - status = nf90_inq_varid(nc%id, nc%npl_varname, nc%npl_varid) - status = nf90_inq_varid(nc%id, nc%ntp_varname, nc%ntp_varid) - status = nf90_inq_varid(nc%id, nc%j2rp2_varname, nc%j2rp2_varid) - status = nf90_inq_varid(nc%id, nc%j4rp4_varname, nc%j4rp4_varid) - status = nf90_inq_varid(nc%id, nc%ptype_varname, nc%ptype_varid) - status = nf90_inq_varid(nc%id, nc%varpi_varname, nc%varpi_varid) - status = nf90_inq_varid(nc%id, nc%lam_varname, nc%lam_varid) - status = nf90_inq_varid(nc%id, nc%f_varname, nc%f_varid) - status = nf90_inq_varid(nc%id, nc%cape_varname, nc%cape_varid) - - if (param%integrator == SYMBA) then - status = nf90_inq_varid(nc%id, nc%nplm_varname, nc%nplm_varid) - end if - - if (param%lclose) then - status = nf90_inq_varid(nc%id, nc%origin_type_varname, nc%origin_type_varid) - status = nf90_inq_varid(nc%id, nc%origin_time_varname, nc%origin_time_varid) - status = nf90_inq_varid(nc%id, nc%origin_rh_varname, nc%origin_rh_varid) - status = nf90_inq_varid(nc%id, nc%origin_vh_varname, nc%origin_vh_varid) - status = nf90_inq_varid(nc%id, nc%collision_id_varname, nc%collision_id_varid) - status = nf90_inq_varid(nc%id, nc%discard_time_varname, nc%discard_time_varid) - status = nf90_inq_varid(nc%id, nc%discard_rh_varname, nc%discard_rh_varid) - status = nf90_inq_varid(nc%id, nc%discard_vh_varname, nc%discard_vh_varid) - status = nf90_inq_varid(nc%id, nc%discard_body_id_varname, nc%discard_body_id_varid) - end if - - if (param%lenergy) then - status = nf90_inq_varid(nc%id, nc%ke_orb_varname, nc%KE_orb_varid) - status = nf90_inq_varid(nc%id, nc%ke_spin_varname, nc%KE_spin_varid) - status = nf90_inq_varid(nc%id, nc%pe_varname, nc%PE_varid) - status = nf90_inq_varid(nc%id, nc%L_orb_varname, nc%L_orb_varid) - status = nf90_inq_varid(nc%id, nc%Lspin_varname, nc%Lspin_varid) - status = nf90_inq_varid(nc%id, nc%L_escape_varname, nc%L_escape_varid) - status = nf90_inq_varid(nc%id, nc%Ecollisions_varname, nc%Ecollisions_varid) - status = nf90_inq_varid(nc%id, nc%Euntracked_varname, nc%Euntracked_varid) - status = nf90_inq_varid(nc%id, nc%GMescape_varname, nc%GMescape_varid) - end if - - end associate - - return - end subroutine netcdf_open - - - module function netcdf_read_frame_system(self, nc, param) result(ierr) - !! author: The Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott - !! - !! Read a frame (header plus records for each massive body and active test particle) from an output binary file - implicit none - ! Arguments - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest system object - class(netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular NetCDF dataset - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - ! Return - integer(I4B) :: ierr !! Error code: returns 0 if the read is successful - ! Internals - integer(I4B) :: i, tslot, idmax, npl_check, ntp_check, nplm_check, t_max, str_max, status - real(DP), dimension(:), allocatable :: rtemp - real(DP), dimension(:,:), allocatable :: vectemp - integer(I4B), dimension(:), allocatable :: itemp - logical, dimension(:), allocatable :: validmask, tpmask, plmask - - tslot = param%ioutput - - call nc%open(param, readonly=.true.) - call self%read_hdr(nc, param) - - associate(cb => self%cb, pl => self%pl, tp => self%tp, npl => self%pl%nbody, ntp => self%tp%nbody) - - call pl%setup(npl, param) - call tp%setup(ntp, param) - - call check( nf90_inquire_dimension(nc%id, nc%name_dimid, len=idmax), "netcdf_read_frame_system nf90_inquire_dimension name_dimid" ) - allocate(rtemp(idmax)) - allocate(vectemp(NDIM,idmax)) - allocate(itemp(idmax)) - allocate(validmask(idmax)) - allocate(tpmask(idmax)) - allocate(plmask(idmax)) - call check( nf90_inquire_dimension(nc%id, nc%time_dimid, len=t_max), "netcdf_read_frame_system nf90_inquire_dimension time_dimid" ) - call check( nf90_inquire_dimension(nc%id, nc%str_dimid, len=str_max), "netcdf_read_frame_system nf90_inquire_dimension str_dimid" ) - - ! First filter out only the id slots that contain valid bodies - if (param%in_form == "XV") then - call check( nf90_get_var(nc%id, nc%rh_varid, vectemp(:,:), start=[1, 1, tslot]), "netcdf_read_frame_system filter pass nf90_getvar rh_varid" ) - validmask(:) = vectemp(1,:) == vectemp(1,:) - else - call check( nf90_get_var(nc%id, nc%a_varid, rtemp(:), start=[1, tslot]), "netcdf_read_frame_system filter pass nf90_getvar a_varid" ) - validmask(:) = rtemp(:) == rtemp(:) - end if - - ! Next, filter only bodies that don't have mass (test particles) - call check( nf90_get_var(nc%id, nc%Gmass_varid, rtemp(:), start=[1, tslot]), "netcdf_read_frame_system nf90_getvar tp finder Gmass_varid" ) - plmask(:) = rtemp(:) == rtemp(:) .and. validmask(:) - tpmask(:) = .not. plmask(:) .and. validmask(:) - plmask(1) = .false. ! This is the central body - - ! Check to make sure the number of bodies is correct - npl_check = count(plmask(:)) - ntp_check = count(tpmask(:)) - - if (npl_check /= npl) then - write(*,*) "Error reading in NetCDF file: The recorded value of npl does not match the number of active massive bodies" - call util_exit(failure) - end if - - if (ntp_check /= ntp) then - write(*,*) "Error reading in NetCDF file: The recorded value of ntp does not match the number of active test particles" - call util_exit(failure) - end if - - select type (pl) - class is (symba_pl) - select type (param) - class is (symba_parameters) - nplm_check = count(pack(rtemp,plmask) > param%GMTINY ) - if (nplm_check /= pl%nplm) then - write(*,*) "Error reading in NetCDF file: The recorded value of nplm does not match the number of active fully interacting massive bodies" - call util_exit(failure) - end if - end select - end select - - ! Now read in each variable and split the outputs by body type - if ((param%in_form == "XV") .or. (param%in_form == "XVEL")) then - call check( nf90_get_var(nc%id, nc%rh_varid, vectemp, start=[1, 1, tslot], count=[NDIM,idmax,1]), "netcdf_read_frame_system nf90_getvar rh_varid" ) - do i = 1, NDIM - if (npl > 0) pl%rh(i,:) = pack(vectemp(i,:), plmask(:)) - if (ntp > 0) tp%rh(i,:) = pack(vectemp(i,:), tpmask(:)) - end do - - if (param%lgr .and. nc%lpseudo_vel_exists) then - call check( nf90_get_var(nc%id, nc%gr_pseudo_vh_varid, vectemp, start=[1, 1, tslot], count=[NDIM,idmax,1]), "netcdf_read_frame_system nf90_getvar gr_pseudo_vh_varid" ) - do i = 1, NDIM - if (npl > 0) pl%vh(i,:) = pack(vectemp(i,:), plmask(:)) - if (ntp > 0) tp%vh(i,:) = pack(vectemp(i,:), tpmask(:)) - end do - else - call check( nf90_get_var(nc%id, nc%vh_varid, vectemp, start=[1, 1, tslot], count=[NDIM,idmax,1]), "netcdf_read_frame_system nf90_getvar vh_varid" ) - do i = 1, NDIM - if (npl > 0) pl%vh(i,:) = pack(vectemp(i,:), plmask(:)) - if (ntp > 0) tp%vh(i,:) = pack(vectemp(i,:), tpmask(:)) - end do - end if - end if - - if ((param%in_form == "EL") .or. (param%in_form == "XVEL")) then - call check( nf90_get_var(nc%id, nc%a_varid, rtemp, start=[1, tslot], count=[idmax,1]), "netcdf_read_frame_system nf90_getvar a_varid" ) - if (.not.allocated(pl%a)) allocate(pl%a(npl)) - if (.not.allocated(tp%a)) allocate(tp%a(ntp)) - if (npl > 0) pl%a(:) = pack(rtemp, plmask) - if (ntp > 0) tp%a(:) = pack(rtemp, tpmask) - - call check( nf90_get_var(nc%id, nc%e_varid, rtemp, start=[1, tslot], count=[idmax,1]), "netcdf_read_frame_system nf90_getvar e_varid" ) - if (.not.allocated(pl%e)) allocate(pl%e(npl)) - if (.not.allocated(tp%e)) allocate(tp%e(ntp)) - if (npl > 0) pl%e(:) = pack(rtemp, plmask) - if (ntp > 0) tp%e(:) = pack(rtemp, tpmask) - - call check( nf90_get_var(nc%id, nc%inc_varid, rtemp, start=[1, tslot], count=[idmax,1]), "netcdf_read_frame_system nf90_getvar inc_varid" ) - rtemp = rtemp * DEG2RAD - if (.not.allocated(pl%inc)) allocate(pl%inc(npl)) - if (.not.allocated(tp%inc)) allocate(tp%inc(ntp)) - if (npl > 0) pl%inc(:) = pack(rtemp, plmask) - if (ntp > 0) tp%inc(:) = pack(rtemp, tpmask) - - call check( nf90_get_var(nc%id, nc%capom_varid, rtemp, start=[1, tslot], count=[idmax,1]), "netcdf_read_frame_system nf90_getvar capom_varid" ) - rtemp = rtemp * DEG2RAD - if (.not.allocated(pl%capom)) allocate(pl%capom(npl)) - if (.not.allocated(tp%capom)) allocate(tp%capom(ntp)) - if (npl > 0) pl%capom(:) = pack(rtemp, plmask) - if (ntp > 0) tp%capom(:) = pack(rtemp, tpmask) - - call check( nf90_get_var(nc%id, nc%omega_varid, rtemp, start=[1, tslot], count=[idmax,1]), "netcdf_read_frame_system nf90_getvar omega_varid" ) - rtemp = rtemp * DEG2RAD - if (.not.allocated(pl%omega)) allocate(pl%omega(npl)) - if (.not.allocated(tp%omega)) allocate(tp%omega(ntp)) - if (npl > 0) pl%omega(:) = pack(rtemp, plmask) - if (ntp > 0) tp%omega(:) = pack(rtemp, tpmask) - - call check( nf90_get_var(nc%id, nc%capm_varid, rtemp, start=[1, tslot], count=[idmax,1]), "netcdf_read_frame_system nf90_getvar capm_varid" ) - rtemp = rtemp * DEG2RAD - if (.not.allocated(pl%capm)) allocate(pl%capm(npl)) - if (.not.allocated(tp%capm)) allocate(tp%capm(ntp)) - if (npl > 0) pl%capm(:) = pack(rtemp, plmask) - if (ntp > 0) tp%capm(:) = pack(rtemp, tpmask) - - end if - - call check( nf90_get_var(nc%id, nc%Gmass_varid, rtemp, start=[1, tslot], count=[idmax,1]), "netcdf_read_frame_system nf90_getvar Gmass_varid" ) - cb%Gmass = rtemp(1) - cb%mass = cb%Gmass / param%GU - - ! Set initial central body mass for Helio bookkeeping - select type(cb) - class is (symba_cb) - cb%GM0 = cb%Gmass - end select - - - if (npl > 0) then - pl%Gmass(:) = pack(rtemp, plmask) - pl%mass(:) = pl%Gmass(:) / param%GU - - if (param%lrhill_present) then - call check( nf90_get_var(nc%id, nc%rhill_varid, rtemp, start=[1, tslot], count=[idmax,1]), "netcdf_read_frame_system nf90_getvar rhill_varid" ) - pl%rhill(:) = pack(rtemp, plmask) - end if - end if - - if (param%lclose) then - call check( nf90_get_var(nc%id, nc%radius_varid, rtemp, start=[1, tslot], count=[idmax,1]), "netcdf_read_frame_system nf90_getvar radius_varid" ) - cb%radius = rtemp(1) - - ! Set initial central body radius for SyMBA bookkeeping - select type(cb) - class is (symba_cb) - cb%R0 = cb%radius - end select - if (npl > 0) pl%radius(:) = pack(rtemp, plmask) - else - cb%radius = param%rmin - if (npl > 0) pl%radius(:) = 0.0_DP - end if - - if (param%lrotation) then - call check( nf90_get_var(nc%id, nc%Ip_varid, vectemp, start=[1, 1, tslot], count=[NDIM,idmax,1]), "netcdf_read_frame_system nf90_getvar Ip_varid" ) - cb%Ip(:) = vectemp(:,1) - do i = 1, NDIM - if (npl > 0) pl%Ip(i,:) = pack(vectemp(i,:), plmask(:)) - end do - - call check( nf90_get_var(nc%id, nc%rot_varid, vectemp, start=[1, 1, tslot], count=[NDIM,idmax,1]), "netcdf_read_frame_system nf90_getvar rot_varid" ) - cb%rot(:) = vectemp(:,1) - do i = 1, NDIM - if (npl > 0) pl%rot(i,:) = pack(vectemp(i,:), plmask(:)) - end do - - ! Set initial central body angular momentum for Helio bookkeeping - select type(cb) - class is (symba_cb) - cb%L0(:) = cb%Ip(3) * cb%GM0 * cb%R0**2 * cb%rot(:) - end select - end if - - ! if (param%ltides) then - ! call check( nf90_get_var(nc%id, nc%k2_varid, rtemp, start=[1, tslot]), "netcdf_read_frame_system nf90_getvar k2_varid" ) - ! cb%k2 = rtemp(1) - ! if (npl > 0) pl%k2(:) = pack(rtemp, plmask) - - ! call check( nf90_get_var(nc%id, nc%Q_varid, rtemp, start=[1, tslot]), "netcdf_read_frame_system nf90_getvar Q_varid" ) - ! cb%Q = rtemp(1) - ! if (npl > 0) pl%Q(:) = pack(rtemp, plmask) - ! end if - - status = nf90_inq_varid(nc%id, nc%j2rp2_varname, nc%j2rp2_varid) - if (status == nf90_noerr) then - call check( nf90_get_var(nc%id, nc%j2rp2_varid, cb%j2rp2, start=[tslot]), "netcdf_read_frame_system nf90_getvar j2rp2_varid" ) - else - cb%j2rp2 = 0.0_DP - end if - - status = nf90_inq_varid(nc%id, nc%j4rp4_varname, nc%j4rp4_varid) - if (status == nf90_noerr) then - call check( nf90_get_var(nc%id, nc%j4rp4_varid, cb%j4rp4, start=[tslot]), "netcdf_read_frame_system nf90_getvar j4rp4_varid" ) - else - cb%j4rp4 = 0.0_DP - end if - - call self%read_particle_info(nc, param, plmask, tpmask) - - if (param%in_form == "EL") then - call pl%el2xv(cb) - call tp%el2xv(cb) - end if - ! if this is a GR-enabled run, check to see if we got the pseudovelocities in. Otherwise, we'll need to generate them. - if (param%lgr .and. .not.(nc%lpseudo_vel_exists)) then - call pl%set_mu(cb) - call tp%set_mu(cb) - call pl%v2pv(param) - call tp%v2pv(param) - end if - - end associate - - call nc%close() - - ierr = 0 - return - - 667 continue - write(*,*) "Error reading system frame in netcdf_read_frame_system" - - end function netcdf_read_frame_system - - - module subroutine netcdf_read_hdr_system(self, nc, param) - !! author: David A. Minton - !! - !! Reads header information (variables that change with time, but not particle id). - !! This subroutine significantly improves the output over the original binary file, allowing us to track energy, momentum, and other quantities that - !! previously were handled as separate output files. - implicit none - ! Arguments - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object - class(netcdf_parameters), intent(inout) :: nc !! Parameters used to for writing a NetCDF dataset to file - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - ! Internals - integer(I4B) :: tslot, status, idmax - real(DP), dimension(:), allocatable :: gmtemp - logical, dimension(:), allocatable :: plmask, tpmask, plmmask - - - tslot = param%ioutput - call check( nf90_inquire_dimension(nc%id, nc%name_dimid, len=idmax), "netcdf_read_hdr_system nf90_inquire_dimension name_dimid" ) - call check( nf90_get_var(nc%id, nc%time_varid, self%t, start=[tslot]), "netcdf_read_hdr_system nf90_getvar time_varid" ) - - allocate(gmtemp(idmax)) - allocate(tpmask(idmax)) - allocate(plmask(idmax)) - allocate(plmmask(idmax)) - - call check( nf90_get_var(nc%id, nc%Gmass_varid, gmtemp, start=[1,1], count=[idmax,1]), "netcdf_read_hdr_system nf90_getvar Gmass_varid" ) - - plmask(:) = gmtemp(:) == gmtemp(:) - tpmask(:) = .not. plmask(:) - plmask(1) = .false. ! This is the central body - select type (param) - class is (symba_parameters) - plmmask(:) = plmask(:) - where(plmask(:)) - plmmask(:) = gmtemp(:) > param%GMTINY - endwhere - end select - - status = nf90_inq_varid(nc%id, nc%npl_varname, nc%npl_varid) - if (status == nf90_noerr) then - call check( nf90_get_var(nc%id, nc%npl_varid, self%pl%nbody, start=[tslot]), "netcdf_read_hdr_system nf90_getvar npl_varid" ) - else - self%pl%nbody = count(plmask(:)) - end if - - status = nf90_inq_varid(nc%id, nc%ntp_varname, nc%ntp_varid) - if (status == nf90_noerr) then - call check( nf90_get_var(nc%id, nc%ntp_varid, self%tp%nbody, start=[tslot]), "netcdf_read_hdr_system nf90_getvar ntp_varid" ) - else - self%tp%nbody = count(tpmask(:)) - end if - - if (param%integrator == SYMBA) then - status = nf90_inq_varid(nc%id, nc%nplm_varname, nc%nplm_varid) - select type(pl => self%pl) - class is (symba_pl) - if (status == nf90_noerr) then - call check( nf90_get_var(nc%id, nc%nplm_varid, pl%nplm, start=[tslot]), "netcdf_read_hdr_system nf90_getvar nplm_varid" ) - else - pl%nplm = count(plmmask(:)) - end if - end select - end if - - if (param%lenergy) then - status = nf90_inq_varid(nc%id, nc%ke_orb_varname, nc%KE_orb_varid) - if (status == nf90_noerr) call check( nf90_get_var(nc%id, nc%KE_orb_varid, self%ke_orbit, start=[tslot]), "netcdf_read_hdr_system nf90_getvar KE_orb_varid" ) - status = nf90_inq_varid(nc%id, nc%ke_spin_varname, nc%KE_spin_varid) - if (status == nf90_noerr) call check( nf90_get_var(nc%id, nc%KE_spin_varid, self%ke_spin, start=[tslot]), "netcdf_read_hdr_system nf90_getvar KE_spin_varid" ) - status = nf90_inq_varid(nc%id, nc%pe_varname, nc%PE_varid) - if (status == nf90_noerr) call check( nf90_get_var(nc%id, nc%PE_varid, self%pe, start=[tslot]), "netcdf_read_hdr_system nf90_getvar PE_varid" ) - status = nf90_inq_varid(nc%id, nc%L_orb_varname, nc%L_orb_varid) - if (status == nf90_noerr) call check( nf90_get_var(nc%id, nc%L_orb_varid, self%Lorbit(:), start=[1,tslot], count=[NDIM,1]), "netcdf_read_hdr_system nf90_getvar L_orb_varid" ) - status = nf90_inq_varid(nc%id, nc%Lspin_varname, nc%Lspin_varid) - if (status == nf90_noerr) call check( nf90_get_var(nc%id, nc%Lspin_varid, self%Lspin(:), start=[1,tslot], count=[NDIM,1]), "netcdf_read_hdr_system nf90_getvar Lspin_varid" ) - status = nf90_inq_varid(nc%id, nc%L_escape_varname, nc%L_escape_varid) - if (status == nf90_noerr) call check( nf90_get_var(nc%id, nc%L_escape_varid, self%Lescape(:), start=[1, tslot], count=[NDIM,1]), "netcdf_read_hdr_system nf90_getvar L_escape_varid" ) - status = nf90_inq_varid(nc%id, nc%Ecollisions_varname, nc%Ecollisions_varid) - if (status == nf90_noerr) call check( nf90_get_var(nc%id, nc%Ecollisions_varid, self%Ecollisions, start=[tslot]), "netcdf_read_hdr_system nf90_getvar Ecollisions_varid" ) - status = nf90_inq_varid(nc%id, nc%Euntracked_varname, nc%Euntracked_varid) - if (status == nf90_noerr) call check( nf90_get_var(nc%id, nc%Euntracked_varid, self%Euntracked, start=[tslot]), "netcdf_read_hdr_system nf90_getvar Euntracked_varid" ) - status = nf90_inq_varid(nc%id, nc%GMescape_varname, nc%GMescape_varid) - if (status == nf90_noerr) call check( nf90_get_var(nc%id, nc%GMescape_varid, self%GMescape, start=[tslot]), "netcdf_read_hdr_system nf90_getvar GMescape_varid" ) - end if - - return - end subroutine netcdf_read_hdr_system - - - module subroutine netcdf_read_particle_info_system(self, nc, param, plmask, tpmask) - !! author: Carlisle A. Wishard, Dana Singh, and David A. Minton - !! - !! Reads particle information metadata from file - implicit none - ! Arguments - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object - class(netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular NetCDF dataset - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - logical, dimension(:), intent(in) :: plmask !! Logical array indicating which index values belong to massive bodies - logical, dimension(:), intent(in) :: tpmask !! Logical array indicating which index values belong to test particles - ! Internals - integer(I4B) :: i, idmax, status - real(DP), dimension(:), allocatable :: rtemp - real(DP), dimension(:,:), allocatable :: vectemp - integer(I4B), dimension(:), allocatable :: itemp - character(len=NAMELEN), dimension(:), allocatable :: ctemp - integer(I4B), dimension(:), allocatable :: plind, tpind - - ! This string of spaces of length NAMELEN is used to clear out any old data left behind inside the string variables - idmax = size(plmask) - allocate(rtemp(idmax)) - allocate(vectemp(NDIM,idmax)) - allocate(itemp(idmax)) - allocate(ctemp(idmax)) - - associate(cb => self%cb, pl => self%pl, tp => self%tp, npl => self%pl%nbody, ntp => self%tp%nbody) - - if (npl > 0) then - pl%status(:) = ACTIVE - pl%lmask(:) = .true. - do i = 1, npl - call pl%info(i)%set_value(status="ACTIVE") - end do - allocate(plind(npl)) - plind(:) = pack([(i, i = 1, idmax)], plmask(:)) - end if - if (ntp > 0) then - tp%status(:) = ACTIVE - tp%lmask(:) = .true. - do i = 1, ntp - call tp%info(i)%set_value(status="ACTIVE") - end do - allocate(tpind(ntp)) - tpind(:) = pack([(i, i = 1, idmax)], tpmask(:)) - end if - - call check( nf90_get_var(nc%id, nc%id_varid, itemp), "netcdf_read_particle_info_system nf90_getvar id_varid" ) - cb%id = itemp(1) - pl%id(:) = pack(itemp, plmask) - tp%id(:) = pack(itemp, tpmask) - cb%id = 0 - pl%id(:) = pack([(i,i=0,idmax-1)],plmask) - tp%id(:) = pack([(i,i=0,idmax-1)],tpmask) - - call check( nf90_get_var(nc%id, nc%name_varid, ctemp, count=[NAMELEN, idmax]), "netcdf_read_particle_info_system nf90_getvar name_varid" ) - call cb%info%set_value(name=ctemp(1)) - do i = 1, npl - call pl%info(i)%set_value(name=ctemp(plind(i))) - end do - do i = 1, ntp - call tp%info(i)%set_value(name=ctemp(tpind(i))) - end do - - status = nf90_get_var(nc%id, nc%ptype_varid, ctemp, count=[NAMELEN, idmax]) - if (status /= nf90_noerr) then ! Set default particle types - call cb%info%set_value(particle_type=CB_TYPE_NAME) - - ! Handle semi-interacting bodies in SyMBA - select type(pl) - class is (symba_pl) - select type (param) - class is (symba_parameters) - do i = 1, npl - if (pl%Gmass(i) < param%GMTINY) then - call pl%info(i)%set_value(particle_type=PL_TINY_TYPE_NAME) - else - call pl%info(i)%set_value(particle_type=PL_TYPE_NAME) - end if - end do - end select - class default ! Non-SyMBA massive bodies - do i = 1, npl - call pl%info(i)%set_value(particle_type=PL_TYPE_NAME) - end do - end select - do i = 1, ntp - call tp%info(i)%set_value(particle_type=TP_TYPE_NAME) - end do - else ! Use particle types defined in input file - call cb%info%set_value(particle_type=ctemp(1)) - do i = 1, npl - call pl%info(i)%set_value(particle_type=ctemp(plind(i))) - end do - do i = 1, ntp - call tp%info(i)%set_value(particle_type=ctemp(tpind(i))) - end do - end if - - call cb%info%set_value(status="ACTIVE") - - if (param%lclose) then - - status = nf90_inq_varid(nc%id, nc%origin_type_varname, nc%origin_type_varid) - if (status == nf90_noerr) then - call check( nf90_get_var(nc%id, nc%origin_type_varid, ctemp, count=[NAMELEN, idmax]), "netcdf_read_particle_info_system nf90_getvar origin_type_varid" ) - else - ctemp = "Initial Conditions" - end if - - call cb%info%set_value(origin_type=ctemp(1)) - do i = 1, npl - call pl%info(i)%set_value(origin_type=ctemp(plind(i))) - end do - do i = 1, ntp - call tp%info(i)%set_value(origin_type=ctemp(tpind(i))) - end do - - status = nf90_inq_varid(nc%id, nc%origin_time_varname, nc%origin_time_varid) - if (status == nf90_noerr) then - call check( nf90_get_var(nc%id, nc%origin_time_varid, rtemp), "netcdf_read_particle_info_system nf90_getvar origin_time_varid" ) - else - rtemp = param%t0 - end if - - call cb%info%set_value(origin_time=rtemp(1)) - do i = 1, npl - call pl%info(i)%set_value(origin_time=rtemp(plind(i))) - end do - do i = 1, ntp - call tp%info(i)%set_value(origin_time=rtemp(tpind(i))) - end do - - status = nf90_inq_varid(nc%id, nc%origin_rh_varname, nc%origin_rh_varid) - if (status == nf90_noerr) then - call check( nf90_get_var(nc%id, nc%origin_rh_varid, vectemp(:,:)), "netcdf_read_particle_info_system nf90_getvar origin_rh_varid" ) - else if ((param%out_form == "XV") .or. (param%out_form == "XVEL")) then - call check( nf90_get_var(nc%id, nc%rh_varid, vectemp(:,:)), "netcdf_read_particle_info_system nf90_getvar rh_varid" ) - else - vectemp(:,:) = 0._DP - end if - - do i = 1, npl - call pl%info(i)%set_value(origin_rh=vectemp(:,plind(i))) - end do - do i = 1, ntp - call tp%info(i)%set_value(origin_rh=vectemp(:,tpind(i))) - end do - - status = nf90_inq_varid(nc%id, nc%origin_vh_varname, nc%origin_vh_varid) - if (status == nf90_noerr) then - call check( nf90_get_var(nc%id, nc%origin_vh_varid, vectemp(:,:)), "netcdf_read_particle_info_system nf90_getvar origin_vh_varid" ) - else if ((param%out_form == "XV") .or. (param%out_form == "XVEL")) then - call check( nf90_get_var(nc%id, nc%vh_varid, vectemp(:,:)), "netcdf_read_particle_info_system nf90_getvar vh_varid" ) - else - vectemp(:,:) = 0._DP - end if - - do i = 1, npl - call pl%info(i)%set_value(origin_vh=vectemp(:,plind(i))) - end do - do i = 1, ntp - call tp%info(i)%set_value(origin_vh=vectemp(:,tpind(i))) - end do - - status = nf90_inq_varid(nc%id, nc%collision_id_varname, nc%collision_id_varid) - if (status == nf90_noerr) then - call check( nf90_get_var(nc%id, nc%collision_id_varid, itemp), "netcdf_read_particle_info_system nf90_getvar collision_id_varid" ) - else - itemp = 0 - end if - - do i = 1, npl - call pl%info(i)%set_value(collision_id=itemp(plind(i))) - end do - do i = 1, ntp - call tp%info(i)%set_value(collision_id=itemp(tpind(i))) - end do - - status = nf90_inq_varid(nc%id, nc%discard_time_varname, nc%discard_time_varid) - if (status == nf90_noerr) then - call check( nf90_get_var(nc%id, nc%discard_time_varid, rtemp), "netcdf_read_particle_info_system nf90_getvar discard_time_varid" ) - else - select case (param%out_type) - case("NETCDF_FLOAT") - rtemp(:) = huge(0.0_SP) - case("NETCDF_DOUBLE") - rtemp(:) = huge(0.0_DP) - end select - end if - - call cb%info%set_value(discard_time=rtemp(1)) - do i = 1, npl - call pl%info(i)%set_value(discard_time=rtemp(plind(i))) - end do - do i = 1, ntp - call tp%info(i)%set_value(discard_time=rtemp(tpind(i))) - end do - - status = nf90_inq_varid(nc%id, nc%discard_rh_varname, nc%discard_rh_varid) - if (status == nf90_noerr) then - call check( nf90_get_var(nc%id, nc%discard_rh_varid, vectemp(:,:)), "netcdf_read_particle_info_system nf90_getvar discard_rh_varid" ) - else - vectemp(:,:) = 0.0_DP - end if - - do i = 1, npl - call pl%info(i)%set_value(discard_rh=vectemp(:,plind(i))) - end do - do i = 1, ntp - call tp%info(i)%set_value(discard_rh=vectemp(:,tpind(i))) - end do - - status = nf90_inq_varid(nc%id, nc%discard_vh_varname, nc%discard_vh_varid) - if (status == nf90_noerr) then - call check( nf90_get_var(nc%id, nc%discard_vh_varid, vectemp(:,:)), "netcdf_read_particle_info_system nf90_getvar discard_vh_varid" ) - else - vectemp(:,:) = 0.0_DP - end if - - do i = 1, npl - call pl%info(i)%set_value(discard_vh=vectemp(:,plind(i))) - end do - do i = 1, ntp - call tp%info(i)%set_value(discard_vh=vectemp(:,tpind(i))) - end do - end if - - end associate - - return - end subroutine netcdf_read_particle_info_system - - - module subroutine netcdf_sync(self) - !! author: David A. Minton - !! - !! Syncrhonize the disk and memory buffer of the NetCDF file (e.g. commit the frame files stored in memory to disk) - !! - implicit none - ! Arguments - class(netcdf_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset - - call check( nf90_sync(self%id), "netcdf_sync nf90_sync" ) - - return - end subroutine netcdf_sync - - - module subroutine netcdf_write_frame_base(self, nc, param) - !! author: Carlisle A. Wishard, Dana Singh, and David A. Minton - !! - !! Write a frame of output of either test particle or massive body data to the binary output file - !! Note: If outputting to orbital elements, but sure that the conversion is done prior to calling this method - implicit none - ! Arguments - class(swiftest_base), intent(in) :: self !! Swiftest particle object - class(netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular NetCDF dataset - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - ! Internals - integer(I4B) :: i, j, tslot, idslot, old_mode - integer(I4B), dimension(:), allocatable :: ind - real(DP), dimension(NDIM) :: vh !! Temporary variable to store heliocentric velocity values when converting from pseudovelocity in GR-enabled runs - real(DP) :: a, e, inc, omega, capom, capm, varpi, lam, f, cape, capf - - tslot = param%ioutput - - call self%write_info(nc, param) - - call check( nf90_set_fill(nc%id, nf90_nofill, old_mode), "netcdf_write_frame_base nf90_set_fill" ) - select type(self) - class is (swiftest_body) - associate(n => self%nbody) - if (n == 0) return - - call util_sort(self%id(1:n), ind) - - do i = 1, n - j = ind(i) - idslot = self%id(j) + 1 - - !! Convert from pseudovelocity to heliocentric without replacing the current value of pseudovelocity - if (param%lgr) call gr_pseudovel2vel(param, self%mu(j), self%rh(:, j), self%vh(:, j), vh(:)) - - if ((param%out_form == "XV") .or. (param%out_form == "XVEL")) then - call check( nf90_put_var(nc%id, nc%rh_varid, self%rh(:, j), start=[1,idslot, tslot], count=[NDIM,1,1]), "netcdf_write_frame_base nf90_put_var rh_varid" ) - if (param%lgr) then !! Convert from pseudovelocity to heliocentric without replacing the current value of pseudovelocity - call check( nf90_put_var(nc%id, nc%vh_varid, vh(:), start=[1,idslot, tslot], count=[NDIM,1,1]), "netcdf_write_frame_base nf90_put_var vh_varid" ) - call check( nf90_put_var(nc%id, nc%gr_pseudo_vh_varid, self%vh(:, j), start=[1,idslot, tslot],count=[NDIM,1,1]), "netcdf_write_frame_base nf90_put_var gr_pseudo_vhx_varid" ) - - else - call check( nf90_put_var(nc%id, nc%vh_varid, self%vh(:, j), start=[1,idslot, tslot], count=[NDIM,1,1]), "netcdf_write_frame_base nf90_put_var vh_varid" ) - end if - end if - - if ((param%out_form == "EL") .or. (param%out_form == "XVEL")) then - if (param%lgr) then !! For GR-enabled runs, use the true value of velocity computed above - call orbel_xv2el(self%mu(j), self%rh(1,j), self%rh(2,j), self%rh(3,j), & - vh(1), vh(2), vh(3), & - a, e, inc, capom, omega, capm, varpi, lam, f, cape, capf) - else !! For non-GR runs just convert from the velocity we have - call orbel_xv2el(self%mu(j), self%rh(1,j), self%rh(2,j), self%rh(3,j), & - self%vh(1,j), self%vh(2,j), self%vh(3,j), & - a, e, inc, capom, omega, capm, varpi, lam, f, cape, capf) - end if - call check( nf90_put_var(nc%id, nc%a_varid, a, start=[idslot, tslot]), "netcdf_write_frame_base nf90_put_var body a_varid" ) - call check( nf90_put_var(nc%id, nc%e_varid, e, start=[idslot, tslot]), "netcdf_write_frame_base nf90_put_var body e_varid" ) - call check( nf90_put_var(nc%id, nc%inc_varid, inc * RAD2DEG, start=[idslot, tslot]), "netcdf_write_frame_base nf90_put_var body inc_varid" ) - call check( nf90_put_var(nc%id, nc%capom_varid, capom * RAD2DEG, start=[idslot, tslot]), "netcdf_write_frame_base nf90_put_var body capom_varid" ) - call check( nf90_put_var(nc%id, nc%omega_varid, omega * RAD2DEG, start=[idslot, tslot]), "netcdf_write_frame_base nf90_put_var body omega_varid" ) - call check( nf90_put_var(nc%id, nc%capm_varid, capm * RAD2DEG, start=[idslot, tslot]), "netcdf_write_frame_base nf90_put_var body capm_varid" ) - call check( nf90_put_var(nc%id, nc%varpi_varid, varpi * RAD2DEG, start=[idslot, tslot]), "netcdf_write_frame_base nf90_put_var body varpi_varid" ) - call check( nf90_put_var(nc%id, nc%lam_varid, lam * RAD2DEG, start=[idslot, tslot]), "netcdf_write_frame_base nf90_put_var body lam_varid" ) - call check( nf90_put_var(nc%id, nc%f_varid, f * RAD2DEG, start=[idslot, tslot]), "netcdf_write_frame_base nf90_put_var body f_varid" ) - if (e < 1.0_DP) then - call check( nf90_put_var(nc%id, nc%cape_varid, cape * RAD2DEG, start=[idslot, tslot]), "netcdf_write_frame_base nf90_put_var body cape_varid" ) - else if (e > 1.0_DP) then - call check( nf90_put_var(nc%id, nc%cape_varid, capf * RAD2DEG, start=[idslot, tslot]), "netcdf_write_frame_base nf90_put_var body (capf) cape_varid" ) - end if - end if - - select type(self) - class is (swiftest_pl) ! Additional output if the passed polymorphic object is a massive body - call check( nf90_put_var(nc%id, nc%Gmass_varid, self%Gmass(j), start=[idslot, tslot]), "netcdf_write_frame_base nf90_put_var body Gmass_varid" ) - if (param%lrhill_present) then - call check( nf90_put_var(nc%id, nc%rhill_varid, self%rhill(j), start=[idslot, tslot]), "netcdf_write_frame_base nf90_put_var body rhill_varid" ) - end if - if (param%lclose) call check( nf90_put_var(nc%id, nc%radius_varid, self%radius(j), start=[idslot, tslot]), "netcdf_write_frame_base nf90_put_var body radius_varid" ) - if (param%lrotation) then - call check( nf90_put_var(nc%id, nc%Ip_varid, self%Ip(:, j), start=[1,idslot, tslot], count=[NDIM,1,1]), "netcdf_write_frame_base nf90_put_var body Ip_varid" ) - call check( nf90_put_var(nc%id, nc%rot_varid, self%rot(:, j), start=[1,idslot, tslot], count=[NDIM,1,1]), "netcdf_write_frame_base nf90_put_var body rotx_varid" ) - end if - ! if (param%ltides) then - ! call check( nf90_put_var(nc%id, nc%k2_varid, self%k2(j), start=[idslot, tslot]), "netcdf_write_frame_base nf90_put_var body k2_varid" ) - ! call check( nf90_put_var(nc%id, nc%Q_varid, self%Q(j), start=[idslot, tslot]), "netcdf_write_frame_base nf90_put_var body Q_varid" ) - ! end if - - end select - end do - end associate - class is (swiftest_cb) - idslot = self%id + 1 - call check( nf90_put_var(nc%id, nc%id_varid, self%id, start=[idslot]), "netcdf_write_frame_base nf90_put_var cb id_varid" ) - - call check( nf90_put_var(nc%id, nc%Gmass_varid, self%Gmass, start=[idslot, tslot]), "netcdf_write_frame_base nf90_put_var cb Gmass_varid" ) - if (param%lclose) call check( nf90_put_var(nc%id, nc%radius_varid, self%radius, start=[idslot, tslot]), "netcdf_write_frame_base nf90_put_var cb radius_varid" ) - call check( nf90_put_var(nc%id, nc%j2rp2_varid, self%j2rp2, start=[tslot]), "netcdf_write_frame_base nf90_put_var cb j2rp2_varid" ) - call check( nf90_put_var(nc%id, nc%j4rp4_varid, self%j4rp4, start=[tslot]), "netcdf_write_frame_base nf90_put_var cb j4rp4_varid" ) - if (param%lrotation) then - call check( nf90_put_var(nc%id, nc%Ip_varid, self%Ip(:), start=[1, idslot, tslot], count=[NDIM,1,1]), "netcdf_write_frame_base nf90_put_var cb Ip_varid" ) - call check( nf90_put_var(nc%id, nc%rot_varid, self%rot(:), start=[1, idslot, tslot], count=[NDIM,1,1]), "netcdf_write_frame_base nf90_put_var cb rot_varid" ) - end if - ! if (param%ltides) then - ! call check( nf90_put_var(nc%id, nc%k2_varid, self%k2, start=[idslot, tslot]), "netcdf_write_frame_base nf90_put_var cb k2_varid" ) - ! call check( nf90_put_var(nc%id, nc%Q_varid, self%Q, start=[idslot, tslot]), "netcdf_write_frame_base nf90_put_var cb Q_varid" ) - ! end if - - end select - call check( nf90_set_fill(nc%id, old_mode, old_mode), "netcdf_write_frame_base nf90_set_fill old_mode" ) - - return - end subroutine netcdf_write_frame_base - - - module subroutine netcdf_write_frame_system(self, nc, param) - !! author: The Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott - !! - !! Write a frame (header plus records for each massive body and active test particle) to a output binary file - implicit none - ! Arguments - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest system object - class(netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular NetCDF dataset - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - - call self%write_hdr(nc, param) - call self%cb%write_frame(nc, param) - call self%pl%write_frame(nc, param) - call self%tp%write_frame(nc, param) - - return - end subroutine netcdf_write_frame_system - - - module subroutine netcdf_write_info_base(self, nc, param) - !! author: Carlisle A. Wishard, Dana Singh, and David A. Minton - !! - !! Write all current particle to file - implicit none - ! Arguments - class(swiftest_base), intent(in) :: self !! Swiftest particle object - class(netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular NetCDF dataset - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - ! Internals - integer(I4B) :: i, j, idslot, old_mode - integer(I4B), dimension(:), allocatable :: ind - character(len=:), allocatable :: charstring - - ! This string of spaces of length NAMELEN is used to clear out any old data left behind inside the string variables - call check( nf90_set_fill(nc%id, nf90_nofill, old_mode), "netcdf_write_info_base nf90_set_fill nf90_nofill" ) - - select type(self) - class is (swiftest_body) - associate(n => self%nbody) - if (n == 0) return - call util_sort(self%id(1:n), ind) - - do i = 1, n - j = ind(i) - idslot = self%id(j) + 1 - call check( nf90_put_var(nc%id, nc%id_varid, self%id(j), start=[idslot]), "netcdf_write_info_base nf90_put_var id_varid" ) - - charstring = trim(adjustl(self%info(j)%name)) - call check( nf90_put_var(nc%id, nc%name_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "netcdf_write_info_base nf90_put_var name_varid" ) - - charstring = trim(adjustl(self%info(j)%particle_type)) - call check( nf90_put_var(nc%id, nc%ptype_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "netcdf_write_info_base nf90_put_var particle_type_varid" ) - - if (param%lclose) then - charstring = trim(adjustl(self%info(j)%origin_type)) - call check( nf90_put_var(nc%id, nc%origin_type_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "netcdf_write_info_base nf90_put_var origin_type_varid" ) - call check( nf90_put_var(nc%id, nc%origin_time_varid, self%info(j)%origin_time, start=[idslot]), "netcdf_write_info_base nf90_put_var origin_time_varid" ) - call check( nf90_put_var(nc%id, nc%origin_rh_varid, self%info(j)%origin_rh(:), start=[1,idslot], count=[NDIM,1]), "netcdf_write_info_base nf90_put_var origin_rh_varid" ) - call check( nf90_put_var(nc%id, nc%origin_vh_varid, self%info(j)%origin_vh(:), start=[1,idslot], count=[NDIM,1]), "netcdf_write_info_base nf90_put_var origin_vh_varid" ) - - call check( nf90_put_var(nc%id, nc%collision_id_varid, self%info(j)%collision_id, start=[idslot]), "netcdf_write_info_base nf90_put_var collision_id_varid" ) - call check( nf90_put_var(nc%id, nc%discard_time_varid, self%info(j)%discard_time, start=[idslot]), "netcdf_write_info_base nf90_put_var discard_time_varid" ) - call check( nf90_put_var(nc%id, nc%discard_rh_varid, self%info(j)%discard_rh(:), start=[1,idslot], count=[NDIM,1]), "netcdf_write_info_base nf90_put_var discard_rh_varid" ) - call check( nf90_put_var(nc%id, nc%discard_vh_varid, self%info(j)%discard_vh(:), start=[1,idslot], count=[NDIM,1]), "netcdf_write_info_base nf90_put_var discard_vh_varid" ) - end if - - end do - end associate - - class is (swiftest_cb) - idslot = self%id + 1 - call check( nf90_put_var(nc%id, nc%id_varid, self%id, start=[idslot]), "netcdf_write_info_base nf90_put_var cb id_varid" ) - - charstring = trim(adjustl(self%info%name)) - call check( nf90_put_var(nc%id, nc%name_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "netcdf_write_info_base nf90_put_var cb name_varid" ) - - charstring = trim(adjustl(self%info%particle_type)) - call check( nf90_put_var(nc%id, nc%ptype_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "netcdf_write_info_base nf90_put_var cb ptype_varid" ) - - if (param%lclose) then - charstring = trim(adjustl(self%info%origin_type)) - call check( nf90_put_var(nc%id, nc%origin_type_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "netcdf_write_info_base nf90_put_var cb origin_type_varid" ) - - call check( nf90_put_var(nc%id, nc%origin_time_varid, self%info%origin_time, start=[idslot]), "netcdf_write_info_base nf90_put_var cb origin_time_varid" ) - call check( nf90_put_var(nc%id, nc%origin_rh_varid, self%info%origin_rh(:), start=[1, idslot], count=[NDIM,1]), "netcdf_write_info_base nf90_put_var cb origin_rh_varid" ) - call check( nf90_put_var(nc%id, nc%origin_vh_varid, self%info%origin_vh(:), start=[1, idslot], count=[NDIM,1]), "netcdf_write_info_base nf90_put_var cb origin_vh_varid" ) - - call check( nf90_put_var(nc%id, nc%collision_id_varid, self%info%collision_id, start=[idslot]), "netcdf_write_info_base nf90_put_var cb collision_id_varid" ) - call check( nf90_put_var(nc%id, nc%discard_time_varid, self%info%discard_time, start=[idslot]), "netcdf_write_info_base nf90_put_var cb discard_time_varid" ) - call check( nf90_put_var(nc%id, nc%discard_rh_varid, self%info%discard_rh(:), start=[1, idslot], count=[NDIM,1]), "netcdf_write_info_base nf90_put_var cb discard_rh_varid" ) - call check( nf90_put_var(nc%id, nc%discard_vh_varid, self%info%discard_vh(:), start=[1, idslot], count=[NDIM,1]), "netcdf_write_info_base nf90_put_var cb discard_vh_varid" ) - end if - - end select - - call check( nf90_set_fill(nc%id, old_mode, old_mode) ) - return - end subroutine netcdf_write_info_base - - - module subroutine netcdf_write_hdr_system(self, nc, param) - !! author: David A. Minton - !! - !! Writes header information (variables that change with time, but not particle id). - !! This subroutine significantly improves the output over the original binary file, allowing us to track energy, momentum, and other quantities that - !! previously were handled as separate output files. - implicit none - ! Arguments - class(swiftest_nbody_system), intent(in) :: self !! Swiftest nbody system object - class(netcdf_parameters), intent(inout) :: nc !! Parameters used to for writing a NetCDF dataset to file - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - ! Internals - integer(I4B) :: tslot - - tslot = param%ioutput - - call check( nf90_put_var(nc%id, nc%time_varid, self%t, start=[tslot]), "netcdf_write_hdr_system nf90_put_var time_varid" ) - call check( nf90_put_var(nc%id, nc%npl_varid, self%pl%nbody, start=[tslot]), "netcdf_write_hdr_system nf90_put_var npl_varid" ) - call check( nf90_put_var(nc%id, nc%ntp_varid, self%tp%nbody, start=[tslot]), "netcdf_write_hdr_system nf90_put_var ntp_varid" ) - select type(pl => self%pl) - class is (symba_pl) - call check( nf90_put_var(nc%id, nc%nplm_varid, pl%nplm, start=[tslot]), "netcdf_write_hdr_system nf90_put_var nplm_varid" ) - end select - - if (param%lenergy) then - call check( nf90_put_var(nc%id, nc%KE_orb_varid, self%ke_orbit, start=[tslot]), "netcdf_write_hdr_system nf90_put_var KE_orb_varid" ) - call check( nf90_put_var(nc%id, nc%KE_spin_varid, self%ke_spin, start=[tslot]), "netcdf_write_hdr_system nf90_put_var KE_spin_varid" ) - call check( nf90_put_var(nc%id, nc%PE_varid, self%pe, start=[tslot]), "netcdf_write_hdr_system nf90_put_var PE_varid" ) - call check( nf90_put_var(nc%id, nc%L_orb_varid, self%Lorbit(:), start=[1,tslot], count=[NDIM,1]), "netcdf_write_hdr_system nf90_put_var L_orb_varid" ) - call check( nf90_put_var(nc%id, nc%Lspin_varid, self%Lspin(:), start=[1,tslot], count=[NDIM,1]), "netcdf_write_hdr_system nf90_put_var Lspin_varid" ) - call check( nf90_put_var(nc%id, nc%L_escape_varid, self%Lescape(:), start=[1,tslot], count=[NDIM,1]), "netcdf_write_hdr_system nf90_put_var L_escape_varid" ) - call check( nf90_put_var(nc%id, nc%Ecollisions_varid, self%Ecollisions, start=[tslot]), "netcdf_write_hdr_system nf90_put_var Ecollisions_varid" ) - call check( nf90_put_var(nc%id, nc%Euntracked_varid, self%Euntracked, start=[tslot]), "netcdf_write_hdr_system nf90_put_var Euntracked_varid" ) - call check( nf90_put_var(nc%id, nc%GMescape_varid, self%GMescape, start=[tslot]), "netcdf_write_hdr_system nf90_put_var GMescape_varid" ) - end if - - return - end subroutine netcdf_write_hdr_system - -end submodule s_netcdf diff --git a/src/operators/operator_cross.f90 b/src/operators/operator_cross.f90 index 2a9af1ecf..cec60d23b 100644 --- a/src/operators/operator_cross.f90 +++ b/src/operators/operator_cross.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(swiftest_operators) s_operator_cross +submodule(operators) s_operator_cross use swiftest !! author: David A. Minton !! diff --git a/src/operators/operator_mag.f90 b/src/operators/operator_mag.f90 index 2cf9e643c..cdbd2b773 100644 --- a/src/operators/operator_mag.f90 +++ b/src/operators/operator_mag.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(swiftest_operators) s_operator_mag +submodule(operators) s_operator_mag !! author: David A. Minton !! !! Contains implementations for the .mag. operator for all defined real types diff --git a/src/operators/operator_unit.f90 b/src/operators/operator_unit.f90 index 8ba5d89e5..2b75e3851 100644 --- a/src/operators/operator_unit.f90 +++ b/src/operators/operator_unit.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(swiftest_operators) s_operator_unit +submodule(operators) s_operator_unit !! author: David A. Minton !! !! Contains implementations for the .unit. operator for all defined real types diff --git a/src/rmvs/rmvs_discard.f90 b/src/rmvs/rmvs_discard.f90 index 1b3a58ddc..06086444c 100644 --- a/src/rmvs/rmvs_discard.f90 +++ b/src/rmvs/rmvs_discard.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(rmvs_classes) s_rmvs_discard +submodule(rmvs) s_rmvs_discard use swiftest contains diff --git a/src/rmvs/rmvs_encounter_check.f90 b/src/rmvs/rmvs_encounter_check.f90 index be0c8ba62..664821272 100644 --- a/src/rmvs/rmvs_encounter_check.f90 +++ b/src/rmvs/rmvs_encounter_check.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule (rmvs_classes) s_rmvs_chk +submodule (rmvs) s_rmvs_chk use swiftest contains diff --git a/src/rmvs/rmvs_kick.f90 b/src/rmvs/rmvs_kick.f90 index 88b71d0a9..2f36bbb81 100644 --- a/src/rmvs/rmvs_kick.f90 +++ b/src/rmvs/rmvs_kick.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(rmvs_classes) s_rmvs_kick +submodule(rmvs) s_rmvs_kick use swiftest contains diff --git a/src/rmvs/rmvs_setup.f90 b/src/rmvs/rmvs_setup.f90 index 9c0b88876..aeea42dfa 100644 --- a/src/rmvs/rmvs_setup.f90 +++ b/src/rmvs/rmvs_setup.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(rmvs_classes) s_rmvs_setup +submodule(rmvs) s_rmvs_setup use swiftest contains diff --git a/src/rmvs/rmvs_step.f90 b/src/rmvs/rmvs_step.f90 index ab39e6f31..7c602a20b 100644 --- a/src/rmvs/rmvs_step.f90 +++ b/src/rmvs/rmvs_step.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(rmvs_classes) s_rmvs_step +submodule(rmvs) s_rmvs_step use swiftest contains @@ -26,7 +26,7 @@ module subroutine rmvs_step_system(self, param, t, dt) real(DP), intent(in) :: dt !! Current stepsiz ! Internals logical :: lencounter, lfirstpl - real(DP), dimension(:,:), allocatable :: rbeg, xend, vbeg + real(DP), dimension(:,:), allocatable :: rbeg, rend, vbeg if (self%tp%nbody == 0) then call whm_step_system(self, param, t, dt) @@ -54,7 +54,7 @@ module subroutine rmvs_step_system(self, param, t, dt) call rmvs_interp_out(cb, pl, dt) call rmvs_step_out(cb, pl, tp, system, param, t, dt) tp%lmask(1:ntp) = .not. tp%lmask(1:ntp) - call pl%set_beg_end(rbeg = rbeg, xend = xend) + call pl%set_beg_end(rbeg = rbeg, rend = rend) tp%lfirst = .true. call tp%step(system, param, t, dt) tp%lmask(1:ntp) = .true. @@ -106,7 +106,7 @@ subroutine rmvs_interp_out(cb, pl, dt) xtmp(:,1:npl) = pl%outer(0)%x(:, 1:npl) vtmp(:,1:npl) = pl%outer(0)%v(:, 1:npl) do outer_index = 1, NTENC - 1 - call drift_one(GMcb(1:npl), xtmp(1,1:npl), xtmp(2,1:npl), xtmp(3,1:npl), & + call swiftest_drift_one(GMcb(1:npl), xtmp(1,1:npl), xtmp(2,1:npl), xtmp(3,1:npl), & vtmp(1,1:npl), vtmp(2,1:npl), vtmp(3,1:npl), & dto(1:npl), iflag(1:npl)) if (any(iflag(1:npl) /= 0)) then @@ -128,7 +128,7 @@ subroutine rmvs_interp_out(cb, pl, dt) xtmp(:, 1:npl) = pl%outer(NTENC)%x(:, 1:npl) vtmp(:, 1:npl) = pl%outer(NTENC)%v(:, 1:npl) do outer_index = NTENC - 1, 1, -1 - call drift_one(GMcb(1:npl), xtmp(1,1:npl), xtmp(2,1:npl), xtmp(3,1:npl), & + call swiftest_drift_one(GMcb(1:npl), xtmp(1,1:npl), xtmp(2,1:npl), xtmp(3,1:npl), & vtmp(1,1:npl), vtmp(2,1:npl), vtmp(3,1:npl), & -dto(1:npl), iflag(1:npl)) if (any(iflag(1:npl) /= 0)) then @@ -187,7 +187,7 @@ subroutine rmvs_step_out(cb, pl, tp, system, param, t, dt) outer_time = t + (outer_index - 1) * dto call pl%set_beg_end(rbeg = pl%outer(outer_index - 1)%x(:, 1:npl), & vbeg = pl%outer(outer_index - 1)%v(:, 1:npl), & - xend = pl%outer(outer_index )%x(:, 1:npl)) + rend = pl%outer(outer_index )%x(:, 1:npl)) lencounter = tp%encounter_check(param, system, dto) if (lencounter) then ! Interpolate planets in inner encounter region @@ -273,7 +273,7 @@ subroutine rmvs_interp_in(cb, pl, system, param, dt, outer_index) ! end if do inner_index = 1, NTPHENC - 1 - call drift_one(GMcb(1:npl), xtmp(1,1:npl), xtmp(2,1:npl), xtmp(3,1:npl), & + call swiftest_drift_one(GMcb(1:npl), xtmp(1,1:npl), xtmp(2,1:npl), xtmp(3,1:npl), & vtmp(1,1:npl), vtmp(2,1:npl), vtmp(3,1:npl), & dti(1:npl), iflag(1:npl)) if (any(iflag(1:npl) /= 0)) then @@ -297,7 +297,7 @@ subroutine rmvs_interp_in(cb, pl, system, param, dt, outer_index) vtmp(:, 1:npl) = pl%inner(NTPHENC)%v(:, 1:npl) do inner_index = NTPHENC - 1, 1, -1 - call drift_one(GMcb(1:npl), xtmp(1,1:npl), xtmp(2,1:npl), xtmp(3,1:npl), & + call swiftest_drift_one(GMcb(1:npl), xtmp(1,1:npl), xtmp(2,1:npl), xtmp(3,1:npl), & vtmp(1,1:npl), vtmp(2,1:npl), vtmp(3,1:npl), & -dti(1:npl), iflag(1:npl)) if (any(iflag(1:npl) /= 0)) then @@ -390,7 +390,7 @@ subroutine rmvs_step_in(cb, pl, tp, param, outer_time, dto) do inner_index = 1, NTPHENC ! Integrate over the encounter region, using the "substitute" planetocentric systems at each level plenci%rh(:, 1:npl) = plenci%inner(inner_index - 1)%x(:, 1:npl) call plenci%set_beg_end(rbeg = plenci%inner(inner_index - 1)%x, & - xend = plenci%inner(inner_index)%x) + rend = plenci%inner(inner_index)%x) if (param%loblatecb) then cbenci%aoblbeg = cbenci%inner(inner_index - 1)%aobl(:, 1) @@ -557,7 +557,7 @@ subroutine rmvs_peri_tp(tp, pl, t, dt, lfirst, inner_index, ipleP, param) if (tp%isperi(i) == -1) then if (vdotr >= 0.0_DP) then tp%isperi(i) = 0 - call orbel_xv2aqt(mu, xpc(1,i), xpc(2,i), xpc(3,i), vpc(1,i), vpc(2,i), vpc(3,i), & + call swiftest_orbel_xv2aqt(mu, xpc(1,i), xpc(2,i), xpc(3,i), vpc(1,i), vpc(2,i), vpc(3,i), & a, peri, capm, tperi) r2 = dot_product(xpc(:, i), xpc(:, i)) if ((abs(tperi) > FACQDT * dt) .or. (r2 > rhill2)) peri = sqrt(r2) diff --git a/src/rmvs/rmvs_util.f90 b/src/rmvs/rmvs_util.f90 index b62c3ad88..a844507dc 100644 --- a/src/rmvs/rmvs_util.f90 +++ b/src/rmvs/rmvs_util.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(rmvs_classes) s_rmvs_util +submodule(rmvs) s_rmvs_util use swiftest contains diff --git a/src/discard/discard.f90 b/src/swiftest_procedures/swiftest_discard.f90 similarity index 95% rename from src/discard/discard.f90 rename to src/swiftest_procedures/swiftest_discard.f90 index fc5160fd7..35a8cb755 100644 --- a/src/discard/discard.f90 +++ b/src/swiftest_procedures/swiftest_discard.f90 @@ -7,11 +7,10 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule (swiftest_classes) s_discard - use swiftest +submodule (swiftest) s_discard contains - module subroutine discard_system(self, param) + module subroutine swiftest_discard_system(self, param) !! author: David A. Minton !! !! Calls the discard methods for each body class and then the write method if any discards were detected @@ -47,10 +46,10 @@ module subroutine discard_system(self, param) end associate return - end subroutine discard_system + end subroutine swiftest_discard_system - module subroutine discard_pl(self, system, param) + module subroutine swiftest_discard_pl(self, system, param) !! author: David A. Minton !! !! Placeholder method for discarding massive bodies. This method does nothing except to ensure that the discard flag is set to false. @@ -65,10 +64,10 @@ module subroutine discard_pl(self, system, param) self%ldiscard(1:self%nbody) = .false. return - end subroutine discard_pl + end subroutine swiftest_discard_pl - module subroutine discard_tp(self, system, param) + module subroutine swiftest_discard_tp(self, system, param) !! author: David A. Minton !! !! Check to see if particles should be discarded based on their positions relative to the massive bodies @@ -104,10 +103,10 @@ module subroutine discard_tp(self, system, param) end associate return - end subroutine discard_tp + end subroutine swiftest_discard_tp - subroutine discard_cb_tp(tp, system, param) + subroutine swiftest_discard_cb_tp(tp, system, param) !! author: David A. Minton !! !! Check to see if test particles should be discarded based on their positions relative to the Sun @@ -173,10 +172,10 @@ subroutine discard_cb_tp(tp, system, param) end associate return - end subroutine discard_cb_tp + end subroutine swiftest_discard_cb_tp - subroutine discard_peri_tp(tp, system, param) + subroutine swiftest_discard_peri_tp(tp, system, param) !! author: David A. Minton !! !! Check to see if a test particle should be discarded because its perihelion distance becomes too small @@ -225,10 +224,10 @@ subroutine discard_peri_tp(tp, system, param) end associate return - end subroutine discard_peri_tp + end subroutine swiftest_discard_peri_tp - subroutine discard_pl_tp(tp, system, param) + subroutine swiftest_discard_pl_tp(tp, system, param) !! author: David A. Minton !! !! Check to see if test particles should be discarded based on their positions relative to the massive bodies @@ -275,10 +274,10 @@ subroutine discard_pl_tp(tp, system, param) end associate return - end subroutine discard_pl_tp + end subroutine swiftest_discard_pl_tp - subroutine discard_pl_close(dx, dv, dt, r2crit, iflag, r2min) + subroutine swiftest_discard_pl_close(dx, dv, dt, r2crit, iflag, r2min) !! author: David A. Minton !! !! Check to see if a test particle and massive body are having, or will have within the next time step, an encounter such @@ -320,6 +319,6 @@ subroutine discard_pl_close(dx, dv, dt, r2crit, iflag, r2min) end if return - end subroutine discard_pl_close + end subroutine swiftest_discard_pl_close end submodule s_discard diff --git a/src/drift/drift.f90 b/src/swiftest_procedures/swiftest_drift.f90 similarity index 88% rename from src/drift/drift.f90 rename to src/swiftest_procedures/swiftest_drift.f90 index 7c7c2bdba..23ea00ee5 100644 --- a/src/drift/drift.f90 +++ b/src/swiftest_procedures/swiftest_drift.f90 @@ -7,8 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule (swiftest_classes) drift_implementation - use swiftest +submodule (swiftest) s_drift !> Integration control parameters: real(DP), parameter :: E2MAX = 0.36_DP real(DP), parameter :: DM2MAX = 0.16_DP @@ -19,7 +18,7 @@ contains - module subroutine drift_body(self, system, param, dt) + module subroutine swiftest_drift_body(self, system, param, dt) !! author: David A. Minton !! !! Loop bodies and call Danby drift routine on the heliocentric position and velocities. @@ -39,7 +38,7 @@ module subroutine drift_body(self, system, param, dt) associate(n => self%nbody) allocate(iflag(n)) iflag(:) = 0 - call drift_all(self%mu, self%rh, self%vh, self%nbody, param, dt, self%lmask, iflag) + call swiftest_drift_all(self%mu, self%rh, self%vh, self%nbody, param, dt, self%lmask, iflag) if (any(iflag(1:n) /= 0)) then where(iflag(1:n) /= 0) self%status(1:n) = DISCARDED_DRIFTERR do i = 1, n @@ -51,10 +50,10 @@ module subroutine drift_body(self, system, param, dt) deallocate(iflag) return - end subroutine drift_body + end subroutine swiftest_drift_body - module subroutine drift_all(mu, x, v, n, param, dt, lmask, iflag) + module subroutine swiftest_drift_all(mu, x, v, n, param, dt, lmask, iflag) !! author: David A. Minton !! !! Loop bodies and call Danby drift routine on all bodies for the given position and velocity vector. @@ -91,17 +90,17 @@ module subroutine drift_all(mu, x, v, n, param, dt, lmask, iflag) !!$omp simd ! SIMD does not yet work do i = 1, n - if (lmask(i)) call drift_one(mu(i), x(1,i), x(2,i), x(3,i), v(1,i), v(2,i), v(3,i), dtp(i), iflag(i)) + if (lmask(i)) call swiftest_drift_one(mu(i), x(1,i), x(2,i), x(3,i), v(1,i), v(2,i), v(3,i), dtp(i), iflag(i)) end do !!$omp end simd deallocate(dtp) return - end subroutine drift_all + end subroutine swiftest_drift_all - pure elemental module subroutine drift_one(mu, px, py, pz, vx, vy, vz, dt, iflag) + pure elemental module subroutine swiftest_drift_one(mu, px, py, pz, vx, vy, vz, dt, iflag) !! author: The Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott !! !! Perform Danby drift for one body, redoing drift with smaller substeps if original accuracy is insufficient @@ -118,20 +117,20 @@ pure elemental module subroutine drift_one(mu, px, py, pz, vx, vy, vz, dt, iflag integer(I4B) :: i real(DP) :: dttmp - call drift_dan(mu, px, py, pz, vx, vy, vz, dt, iflag) + call swiftest_drift_dan(mu, px, py, pz, vx, vy, vz, dt, iflag) if (iflag /= 0) then dttmp = 0.1_DP * dt do i = 1, 10 - call drift_dan(mu, px, py, pz, vx, vy, vz, dttmp, iflag) + call swiftest_drift_dan(mu, px, py, pz, vx, vy, vz, dttmp, iflag) if (iflag /= 0) exit end do end if - + return - end subroutine drift_one + end subroutine swiftest_drift_one - pure subroutine drift_dan(mu, px0, py0, pz0, vx0, vy0, vz0, dt0, iflag) + pure subroutine swiftest_drift_dan(mu, px0, py0, pz0, vx0, vy0, vz0, dt0, iflag) !! author: David A. Minton !! !! Perform Kepler drift, solving Kepler's equation in appropriate variables @@ -169,7 +168,7 @@ pure subroutine drift_dan(mu, px0, py0, pz0, vx0, vy0, vz0, dt0, iflag) dm = dt * en - int(dt * en / TWOPI, kind = I4B) * TWOPI dt = dm / en if ((esq < E2MAX) .and. (dm**2 < DM2MAX) .and. (esq * dm**2 < E2DM2MAX)) then - call drift_kepmd(dm, es, ec, xkep, s, c) + call swiftest_drift_kepmd(dm, es, ec, xkep, s, c) fchk = (xkep - ec * s + es * (1.0_DP - c) - dm) ! DEK - original code compared fchk*fchk with DANBYB, but i think it should ! DEK - be compared with DANBYB*DANBYB, and i changed it accordingly - please @@ -192,7 +191,7 @@ pure subroutine drift_dan(mu, px0, py0, pz0, vx0, vy0, vz0, dt0, iflag) end if end if - call drift_kepu(dt, r0, mu, alpha, u, fp, c1, c2, c3, iflag) + call swiftest_drift_kepu(dt, r0, mu, alpha, u, fp, c1, c2, c3, iflag) if (iflag == 0) then f = 1.0_DP - mu / r0 * c2 g = dt - mu * c3 @@ -205,10 +204,10 @@ pure subroutine drift_dan(mu, px0, py0, pz0, vx0, vy0, vz0, dt0, iflag) end if return - end subroutine drift_dan + end subroutine swiftest_drift_dan - pure subroutine drift_kepmd(dm, es, ec, x, s, c) + pure subroutine swiftest_drift_kepmd(dm, es, ec, x, s, c) !! author: David A. Minton !! !! Solve Kepler's equation in difference form for an ellipse for small input dm and eccentricity @@ -250,10 +249,10 @@ pure subroutine drift_kepmd(dm, es, ec, x, s, c) c = sqrt(1.0_DP - s**2) return - end subroutine drift_kepmd + end subroutine swiftest_drift_kepmd - pure subroutine drift_kepu(dt,r0,mu,alpha,u,fp,c1,c2,c3,iflag) + pure subroutine swiftest_drift_kepu(dt,r0,mu,alpha,u,fp,c1,c2,c3,iflag) !! author: David A. Minton !! !! Solve Kepler's equation in universal variables @@ -267,21 +266,21 @@ pure subroutine drift_kepu(dt,r0,mu,alpha,u,fp,c1,c2,c3,iflag) real(DP) :: s, st, fo, fn ! executable code - call drift_kepu_guess(dt, r0, mu, alpha, u, s) + call swiftest_drift_kepu_guess(dt, r0, mu, alpha, u, s) st = s - call drift_kepu_new(s, dt, r0, mu, alpha, u, fp, c1, c2, c3, iflag) + call swiftest_drift_kepu_new(s, dt, r0, mu, alpha, u, fp, c1, c2, c3, iflag) if (iflag /= 0) then - call drift_kepu_fchk(dt, r0, mu, alpha, u, st, fo) - call drift_kepu_fchk(dt, r0, mu, alpha, u, s, fn) + call swiftest_drift_kepu_fchk(dt, r0, mu, alpha, u, st, fo) + call swiftest_drift_kepu_fchk(dt, r0, mu, alpha, u, s, fn) if (abs(fo) < abs(fn)) s = st - call drift_kepu_lag(s, dt, r0, mu, alpha, u, fp, c1, c2, c3, iflag) + call swiftest_drift_kepu_lag(s, dt, r0, mu, alpha, u, fp, c1, c2, c3, iflag) end if return - end subroutine drift_kepu + end subroutine swiftest_drift_kepu - pure subroutine drift_kepu_fchk(dt, r0, mu, alpha, u, s, f) + pure subroutine swiftest_drift_kepu_fchk(dt, r0, mu, alpha, u, s, f) !! author: David A. Minton !! !! Computes the value of f, the function whose root we are trying to find in universal variables @@ -301,17 +300,17 @@ pure subroutine drift_kepu_fchk(dt, r0, mu, alpha, u, s, f) real(DP) :: x, c0, c1, c2, c3 x = s**2 * alpha - call drift_kepu_stumpff(x, c0, c1, c2, c3) + call swiftest_drift_kepu_stumpff(x, c0, c1, c2, c3) c1 = c1 * s c2 = c2 * s**2 c3 = c3 * s**3 f = r0 * c1 + u * c2 + mu * c3 - dt return - end subroutine drift_kepu_fchk + end subroutine swiftest_drift_kepu_fchk - pure subroutine drift_kepu_guess(dt, r0, mu, alpha, u, s) + pure subroutine swiftest_drift_kepu_guess(dt, r0, mu, alpha, u, s) !! author: David A. Minton !! !! Compute initial guess for solving Kepler's equation using universal variables @@ -341,21 +340,21 @@ pure subroutine drift_kepu_guess(dt, r0, mu, alpha, u, s) es = u / (en * a**2) e = sqrt(ec**2 + es**2) y = en * dt - es - call orbel_scget(y, sy, cy) + call swiftest_orbel_scget(y, sy, cy) sigma = sign(1.0_DP, es * cy + ec * sy) x = y + sigma * danbyk * e s = x / sqrt(alpha) end if else - call drift_kepu_p3solve(dt, r0, mu, alpha, u, s, iflag) + call swiftest_drift_kepu_p3solve(dt, r0, mu, alpha, u, s, iflag) if (iflag /= 0) s = dt / r0 end if return - end subroutine drift_kepu_guess + end subroutine swiftest_drift_kepu_guess - pure subroutine drift_kepu_lag(s, dt, r0, mu, alpha, u, fp, c1, c2, c3, iflag) + pure subroutine swiftest_drift_kepu_lag(s, dt, r0, mu, alpha, u, fp, c1, c2, c3, iflag) !! author: David A. Minton !! !! Solve Kepler's equation in universal variables using Laguerre's method @@ -380,7 +379,7 @@ pure subroutine drift_kepu_lag(s, dt, r0, mu, alpha, u, fp, c1, c2, c3, iflag) integer(I4B) :: nc, ncmax real(DP) :: x, fpp, ds, c0, f, fdt integer(I4B), parameter :: ln = 5 - + if (alpha < 0.0_DP) then ncmax = NLAG2 else @@ -388,7 +387,7 @@ pure subroutine drift_kepu_lag(s, dt, r0, mu, alpha, u, fp, c1, c2, c3, iflag) end if do nc = 0, ncmax x = s * s * alpha - call drift_kepu_stumpff(x, c0, c1, c2, c3) + call swiftest_drift_kepu_stumpff(x, c0, c1, c2, c3) c1 = c1 * s c2 = c2 * s**2 c3 = c3 * s**3 @@ -406,10 +405,10 @@ pure subroutine drift_kepu_lag(s, dt, r0, mu, alpha, u, fp, c1, c2, c3, iflag) iflag = 2 return - end subroutine drift_kepu_lag + end subroutine swiftest_drift_kepu_lag - pure subroutine drift_kepu_new(s, dt, r0, mu, alpha, u, fp, c1, c2, c3, iflag) + pure subroutine swiftest_drift_kepu_new(s, dt, r0, mu, alpha, u, fp, c1, c2, c3, iflag) !! author: David A. Minton !! !! Solve Kepler's equation in universal variables using Newton's method @@ -433,10 +432,10 @@ pure subroutine drift_kepu_new(s, dt, r0, mu, alpha, u, fp, c1, c2, c3, iflag) ! Internals integer( I4B) :: nc real(DP) :: x, c0, ds, f, fpp, fppp, fdt - + do nc = 0, 6 x = s**2 * alpha - call drift_kepu_stumpff(x, c0, c1, c2, c3) + call swiftest_drift_kepu_stumpff(x, c0, c1, c2, c3) c1 = c1 * s c2 = c2 * s**2 c3 = c3 * s**3 @@ -455,12 +454,12 @@ pure subroutine drift_kepu_new(s, dt, r0, mu, alpha, u, fp, c1, c2, c3, iflag) end if end do iflag = 1 - + return - end subroutine drift_kepu_new + end subroutine swiftest_drift_kepu_new - pure subroutine drift_kepu_p3solve(dt, r0, mu, alpha, u, s, iflag) + pure subroutine swiftest_drift_kepu_p3solve(dt, r0, mu, alpha, u, s, iflag) !! author: David A. Minton !! !! Computes real root of cubic involved in setting initial guess for solving Kepler's equation in universal variables @@ -507,10 +506,10 @@ pure subroutine drift_kepu_p3solve(dt, r0, mu, alpha, u, s, iflag) end if return - end subroutine drift_kepu_p3solve - + end subroutine swiftest_drift_kepu_p3solve + - pure subroutine drift_kepu_stumpff(x, c0, c1, c2, c3) + pure subroutine swiftest_drift_kepu_stumpff(x, c0, c1, c2, c3) !! author: David A. Minton !! !! Compute Stumpff functions needed for Kepler drift in universal variables @@ -537,10 +536,10 @@ pure subroutine drift_kepu_stumpff(x, c0, c1, c2, c3) end do c2 = (1.0_DP - x * (1.0_DP - x * (1.0_DP - x * (1.0_DP - x * (1.0_DP - x * & (1.0_DP - x / 182.0_DP) / 132.0_DP) / 90.0_DP) / 56.0_DP) / & - 30.0_DP) / 12.0_DP) / 2.0_DP + 30.0_DP) / 12.0_DP) / 2.0_DP c3 = (1.0_DP - x * (1.0_DP - x * (1.0_DP - x * (1.0_DP - x * (1.0_DP - x * & (1.0_DP - x / 210.0_DP) / 156.0_DP) / 110.0_DP) / 72.0_DP) / & - 42.0_DP) / 20.0_DP ) / 6.0_DP + 42.0_DP) / 20.0_DP ) / 6.0_DP c1 = 1.0_DP - x * c3 c0 = 1.0_DP - x * c2 if (n /= 0) then @@ -554,7 +553,7 @@ pure subroutine drift_kepu_stumpff(x, c0, c1, c2, c3) end if return - end subroutine drift_kepu_stumpff + end subroutine swiftest_drift_kepu_stumpff -end submodule drift_implementation +end submodule s_drift diff --git a/src/gr/gr.f90 b/src/swiftest_procedures/swiftest_gr.f90 similarity index 91% rename from src/gr/gr.f90 rename to src/swiftest_procedures/swiftest_gr.f90 index 0d7fb7aaa..e3467b8c0 100644 --- a/src/gr/gr.f90 +++ b/src/swiftest_procedures/swiftest_gr.f90 @@ -7,11 +7,10 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(swiftest_classes) s_gr - use swiftest +submodule(swiftest) s_gr contains - pure module subroutine gr_kick_getaccb_ns_body(self, system, param) + pure module subroutine swiftest_gr_kick_getaccb_ns_body(self, system, param) !! author: David A. Minton !! !! Add relativistic correction acceleration for non-symplectic integrators. @@ -51,10 +50,10 @@ pure module subroutine gr_kick_getaccb_ns_body(self, system, param) end associate return - end subroutine gr_kick_getaccb_ns_body + end subroutine swiftest_gr_kick_getaccb_ns_body - pure module subroutine gr_kick_getacch(mu, x, lmask, n, inv_c2, agr) + pure module subroutine swiftest_gr_kick_getacch(mu, x, lmask, n, inv_c2, agr) !! author: David A. Minton !! !! Compute relativisitic accelerations of massive bodies @@ -81,10 +80,10 @@ pure module subroutine gr_kick_getacch(mu, x, lmask, n, inv_c2, agr) end do return - end subroutine gr_kick_getacch + end subroutine swiftest_gr_kick_getacch - pure module subroutine gr_p4_pos_kick(param, x, v, dt) + pure module subroutine swiftest_gr_p4_pos_kick(param, x, v, dt) !! author: David A. Minton !! !! Position kick due to p**4 term in the post-Newtonian correction @@ -110,10 +109,10 @@ pure module subroutine gr_p4_pos_kick(param, x, v, dt) x(:) = x(:) + dr(:) * dt return - end subroutine gr_p4_pos_kick + end subroutine swiftest_gr_p4_pos_kick - pure module subroutine gr_pseudovel2vel(param, mu, rh, pv, vh) + pure module subroutine swiftest_gr_pseudovel2vel(param, mu, rh, pv, vh) !! author: David A. Minton !! !! Converts the relativistic pseudovelocity back into a veliocentric velocity @@ -142,10 +141,10 @@ pure module subroutine gr_pseudovel2vel(param, mu, rh, pv, vh) end associate return - end subroutine gr_pseudovel2vel + end subroutine swiftest_gr_pseudovel2vel - pure module subroutine gr_pv2vh_body(self, param) + pure module subroutine swiftest_gr_pv2vh_body(self, param) !! author: David A. Minton !! !! Wrapper function that converts from pseudovelocity to heliocentric velocity for swiftest bodies @@ -161,16 +160,16 @@ pure module subroutine gr_pv2vh_body(self, param) if (n == 0) return allocate(vh, mold = self%vh) do i = 1, n - call gr_pseudovel2vel(param, self%mu(i), self%rh(:, i), self%vh(:, i), vh(:, i)) + call swiftest_gr_pseudovel2vel(param, self%mu(i), self%rh(:, i), self%vh(:, i), vh(:, i)) end do call move_alloc(vh, self%vh) end associate return - end subroutine gr_pv2vh_body + end subroutine swiftest_gr_pv2vh_body - pure module subroutine gr_vel2pseudovel(param, mu, rh, vh, pv) + pure module subroutine swiftest_gr_vel2pseudovel(param, mu, rh, vh, pv) !! author: David A. Minton !! !! Converts the heliocentric velocity into a pseudovelocity with relativistic corrections. @@ -244,10 +243,10 @@ pure module subroutine gr_vel2pseudovel(param, mu, rh, vh, pv) end associate return - end subroutine gr_vel2pseudovel + end subroutine swiftest_gr_vel2pseudovel - pure module subroutine gr_vh2pv_body(self, param) + pure module subroutine swiftest_gr_vh2pv_body(self, param) !! author: David A. Minton !! !! Wrapper function that converts from heliocentric velocity to pseudovelocity for Swiftest bodies @@ -263,12 +262,12 @@ pure module subroutine gr_vh2pv_body(self, param) if (n == 0) return allocate(pv, mold = self%vh) do i = 1, n - call gr_vel2pseudovel(param, self%mu(i), self%rh(:, i), self%vh(:, i), pv(:, i)) + call swiftest_gr_vel2pseudovel(param, self%mu(i), self%rh(:, i), self%vh(:, i), pv(:, i)) end do call move_alloc(pv, self%vh) end associate return - end subroutine gr_vh2pv_body + end subroutine swiftest_gr_vh2pv_body end submodule s_gr \ No newline at end of file diff --git a/src/io/io.f90 b/src/swiftest_procedures/swiftest_io.f90 similarity index 86% rename from src/io/io.f90 rename to src/swiftest_procedures/swiftest_io.f90 index 1f7852ea2..885e77985 100644 --- a/src/io/io.f90 +++ b/src/swiftest_procedures/swiftest_io.f90 @@ -7,12 +7,11 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule (swiftest_classes) s_io - use swiftest - +submodule (swiftest) s_io + use symba contains - module subroutine io_compact_output(self, param, timer) + module subroutine swiftest_io_compact_output(self, param, timer) !! author: David Minton !! !! Generates the terminal output displayed when display_style is set to COMPACT. This is used by the Python driver to @@ -29,7 +28,7 @@ module subroutine io_compact_output(self, param, timer) ! Arguments class(swiftest_nbody_system), intent(in) :: self !! Swiftest nbody system object class(swiftest_parameters), intent(in) :: param !! Input colleciton of user-defined parameters - class(*), intent(in) :: timer !! Object used for computing elapsed wall time (must be unlimited polymorphic because the walltimer module requires swiftest_classes) + class(*), intent(in) :: timer !! Object used for computing elapsed wall time (must be unlimited polymorphic because the walltimer module requires base) ! Internals character(len=:), allocatable :: formatted_output @@ -107,10 +106,10 @@ function fmt_DP(varname, val) result(pair_string) return end function fmt_DP - end subroutine io_compact_output + end subroutine swiftest_io_compact_output - module subroutine io_conservation_report(self, param, lterminal) + module subroutine swiftest_io_conservation_report(self, param, lterminal) !! author: The Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott !! !! Reports the current state of energy, mass, and angular momentum conservation in a run @@ -189,10 +188,10 @@ module subroutine io_conservation_report(self, param, lterminal) 667 continue write(*,*) "Error writing energy and momentum tracking file: " // trim(adjustl(errmsg)) call util_exit(FAILURE) - end subroutine io_conservation_report + end subroutine swiftest_io_conservation_report - module subroutine io_dump_param(self, param_file_name) + module subroutine swiftest_io_dump_param(self, param_file_name) !! author: David A. Minton !! !! Dump integration parameters to file @@ -220,10 +219,10 @@ module subroutine io_dump_param(self, param_file_name) 667 continue write(*,*) "Error opening parameter dump file " // trim(adjustl(errmsg)) call util_exit(FAILURE) - end subroutine io_dump_param + end subroutine swiftest_io_dump_param - module subroutine io_dump_system(self, param) + module subroutine swiftest_io_dump_system(self, param) !! author: David A. Minton !! !! Dumps the state of the system to files in case the simulation is interrupted. @@ -266,19 +265,19 @@ module subroutine io_dump_system(self, param) ! Dump the encounter history if necessary select type(param) - class is (symba_parameters) - if (param%lenc_save_trajectory .or. param%lenc_save_closest) call param%encounter_history%dump(param) - call param%collision_history%dump(param) + class is (swiftest_parameters) + if (param%lenc_save_trajectory .or. param%lenc_save_closest) call self%encounter_history%dump(param) + call self%collision_history%dump(param) end select ! Dump the system history to file call param%system_history%dump(param) return - end subroutine io_dump_system + end subroutine swiftest_io_dump_system - module subroutine io_dump_storage(self, param) + module subroutine swiftest_io_dump_storage(self, param) !! author: David A. Minton !! !! Dumps the time history of the simulation to file. Each time it writes a frame to file, it deallocates the system @@ -308,10 +307,10 @@ module subroutine io_dump_storage(self, param) end do call self%reset() return - end subroutine io_dump_storage + end subroutine swiftest_io_dump_storage - module subroutine io_get_args(integrator, param_file_name, display_style) + module subroutine swiftest_io_get_args(integrator, param_file_name, display_style) !! author: David A. Minton !! !! Reads in the name of the parameter file from command line arguments. @@ -348,22 +347,22 @@ module subroutine io_get_args(integrator, param_file_name, display_style) else if (narg >= 2) then call io_toupper(arg(1)) select case(arg(1)) - case('BS') - integrator = BS - case('HELIO') - integrator = HELIO - case('RA15') - integrator = RA15 - case('TU4') - integrator = TU4 + case('INT_BS') + integrator = INT_BS + case('INT_HELIO') + integrator = INT_HELIO + case('INT_RA15') + integrator = INT_RA15 + case('INT_TU4') + integrator = INT_TU4 case('WHM') - integrator = WHM + integrator = INT_WHM case('RMVS') - integrator = RMVS + integrator = INT_RMVS case('SYMBA') - integrator = SYMBA + integrator = INT_SYMBA case('RINGMOONS') - integrator = RINGMOONS + integrator = INT_RINGMOONS case default integrator = UNKNOWN_INTEGRATOR write(*,*) trim(adjustl(arg(1))) // ' is not a valid integrator.' @@ -382,16 +381,16 @@ module subroutine io_get_args(integrator, param_file_name, display_style) end if return - end subroutine io_get_args + end subroutine swiftest_io_get_args - module function io_get_token(buffer, ifirst, ilast, ierr) result(token) + module function swiftest_io_get_token(buffer, ifirst, ilast, ierr) result(token) !! author: David A. Minton !! !! Retrieves a character token from an input string. Here a token is defined as any set of contiguous non-blank characters not !! beginning with or containing "!". If "!" is present, any remaining part of the buffer including the "!" is ignored !! - !! Adapted from David E. Kaufmann's Swifter routine io_get_token.f90 + !! Adapted from David E. Kaufmann's Swifter routine swiftest_io_get_token.f90 implicit none ! Arguments character(len=*), intent(in) :: buffer !! Input string buffer @@ -431,10 +430,10 @@ module function io_get_token(buffer, ifirst, ilast, ierr) result(token) token = buffer(ifirst:ilast) return - end function io_get_token + end function swiftest_io_get_token - module subroutine io_log_one_message(file, message) + module subroutine swiftest_io_log_one_message(file, message) !! author: David A. Minton !! !! Writes a single message to a log file @@ -452,10 +451,10 @@ module subroutine io_log_one_message(file, message) return 667 continue write(*,*) "Error writing message to log file: " // trim(adjustl(errmsg)) - end subroutine io_log_one_message + end subroutine swiftest_io_log_one_message - module subroutine io_log_start(param, file, header) + module subroutine swiftest_io_log_start(param, file, header) !! author: David A. Minton !! !! Checks to see if a log file needs to be created if this is a new run, or appended if this is a restarted run @@ -479,10 +478,10 @@ module subroutine io_log_start(param, file, header) 667 continue write(*,*) "Error writing log file: " // trim(adjustl(errmsg)) - end subroutine io_log_start + end subroutine swiftest_io_log_start - module subroutine io_param_reader(self, unit, iotype, v_list, iostat, iomsg) + module subroutine swiftest_io_param_reader(self, unit, iotype, v_list, iostat, iomsg) !! author: The Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott !! !! Read in parameters for the integration @@ -509,11 +508,16 @@ module subroutine io_param_reader(self, unit, iotype, v_list, iostat, iomsg) character(STRMAX) :: line !! Line of the input file character(len=:), allocatable :: line_trim,param_name, param_value !! Strings used to parse the param file character(*),parameter :: linefmt = '(A)' !! Format code for simple text string + integer(I4B) :: nseeds, nseeds_from_file + logical :: seed_set = .false. !! Is the random seed set in the input file? character(len=:), allocatable :: integrator ! Parse the file line by line, extracting tokens then matching them up with known parameters if possible associate(param => self) + call random_seed(size = nseeds) + if (allocated(param%seed)) deallocate(param%seed) + allocate(param%seed(nseeds)) open(unit = unit, file = param%param_file_name, status = 'old', err = 667, iomsg = iomsg) do read(unit = unit, fmt = linefmt, end = 1, err = 667, iomsg = iomsg) line @@ -522,11 +526,11 @@ module subroutine io_param_reader(self, unit, iotype, v_list, iostat, iomsg) if ((ilength /= 0)) then ifirst = 1 ! Read the pair of tokens. The first one is the parameter name, the second is the value. - param_name = io_get_token(line_trim, ifirst, ilast, iostat) + param_name = swiftest_io_get_token(line_trim, ifirst, ilast, iostat) if (param_name == '') cycle ! No parameter name (usually because this line is commented out) call io_toupper(param_name) ifirst = ilast + 1 - param_value = io_get_token(line_trim, ifirst, ilast, iostat) + param_value = swiftest_io_get_token(line_trim, ifirst, ilast, iostat) select case (param_name) case ("T0") read(param_value, *, err = 667, iomsg = iomsg) param%t0 @@ -585,7 +589,7 @@ module subroutine io_param_reader(self, unit, iotype, v_list, iostat, iomsg) case ("CHK_QMIN_RANGE") read(param_value, *, err = 667, iomsg = iomsg) param%qmin_alo ifirst = ilast + 1 - param_value = io_get_token(line, ifirst, ilast, iostat) + param_value = swiftest_io_get_token(line, ifirst, ilast, iostat) read(param_value, *, err = 667, iomsg = iomsg) param%qmin_ahi case ("EXTRA_FORCE") call io_toupper(param_value) @@ -641,28 +645,28 @@ module subroutine io_param_reader(self, unit, iotype, v_list, iostat, iomsg) read(param_value, *, err = 667, iomsg = iomsg) param%Ltot_orig(1) do i = 2, NDIM ifirst = ilast + 2 - param_value = io_get_token(line, ifirst, ilast, iostat) + param_value = swiftest_io_get_token(line, ifirst, ilast, iostat) read(param_value, *, err = 667, iomsg = iomsg) param%Ltot_orig(i) end do case("LORBIT_ORIG") read(param_value, *, err = 667, iomsg = iomsg) param%Lorbit_orig(1) do i = 2, NDIM ifirst = ilast + 2 - param_value = io_get_token(line, ifirst, ilast, iostat) + param_value = swiftest_io_get_token(line, ifirst, ilast, iostat) read(param_value, *, err = 667, iomsg = iomsg) param%Lorbit_orig(i) end do case("LSPIN_ORIG") read(param_value, *, err = 667, iomsg = iomsg) param%Lspin_orig(1) do i = 2, NDIM ifirst = ilast + 2 - param_value = io_get_token(line, ifirst, ilast, iostat) + param_value = swiftest_io_get_token(line, ifirst, ilast, iostat) read(param_value, *, err = 667, iomsg = iomsg) param%Lspin_orig(i) end do case("LESCAPE") read(param_value, *, err = 667, iomsg = iomsg) param%Lescape(1) do i = 2, NDIM ifirst = ilast + 2 - param_value = io_get_token(line, ifirst, ilast, iostat) + param_value = swiftest_io_get_token(line, ifirst, ilast, iostat) read(param_value, *, err = 667, iomsg = iomsg) param%Lescape(i) end do case("GMESCAPE") @@ -675,6 +679,40 @@ module subroutine io_param_reader(self, unit, iotype, v_list, iostat, iomsg) read(param_value, *, err = 667, iomsg = iomsg) param%maxid case ("MAXID_COLLISION") read(param_value, *, err = 667, iomsg = iomsg) param%maxid_collision + case ("FRAGMENTATION") + call io_toupper(param_value) + if (param_value == "YES" .or. param_value == "T") self%lfragmentation = .true. + case ("GMTINY") + read(param_value, *) param%GMTINY + case ("MIN_GMFRAG") + read(param_value, *) param%min_GMfrag + case ("ENCOUNTER_SAVE") + call io_toupper(param_value) + read(param_value, *) param%encounter_save + case("SEED") + read(param_value, *) nseeds_from_file + ! Because the number of seeds can vary between compilers/systems, we need to make sure we can handle cases in which the input file has a different + ! number of seeds than the current system. If the number of seeds in the file is smaller than required, we will use them as a source to fill in the missing elements. + ! If the number of seeds in the file is larger than required, we will truncate the seed array. + if (nseeds_from_file > nseeds) then + nseeds = nseeds_from_file + deallocate(param%seed) + allocate(param%seed(nseeds)) + do i = 1, nseeds + ifirst = ilast + 2 + param_value = swiftest_io_get_token(line, ifirst, ilast, iostat) + read(param_value, *) param%seed(i) + end do + else ! Seed array in file is too small + do i = 1, nseeds_from_file + ifirst = ilast + 2 + param_value = swiftest_io_get_token(line, ifirst, ilast, iostat) + read(param_value, *) param%seed(i) + end do + param%seed(nseeds_from_file+1:nseeds) = [(param%seed(1) - param%seed(nseeds_from_file) + i, & + i=nseeds_from_file+1, nseeds)] + end if + seed_set = .true. case ("RESTART") if (param_value == "NO" .or. param_value == 'F') then param%lrestart = .false. @@ -682,7 +720,7 @@ module subroutine io_param_reader(self, unit, iotype, v_list, iostat, iomsg) param%lrestart = .true. end if ! Ignore SyMBA-specific, not-yet-implemented, or obsolete input parameters - case ("NPLMAX", "NTPMAX", "GMTINY", "MIN_GMFRAG", "FRAGMENTATION", "SEED", "YARKOVSKY", "YORP", "ENCOUNTER_SAVE") + case ("NPLMAX", "NTPMAX", "YARKOVSKY", "YORP") case default write(*,*) "Ignoring unknown parameter -> ",param_name end select @@ -774,8 +812,40 @@ module subroutine io_param_reader(self, unit, iotype, v_list, iostat, iomsg) ! Calculate the G for the system units param%GU = GC / (param%DU2M**3 / (param%MU2KG * param%TU2S**2)) + + if (self%GMTINY < 0.0_DP) then + write(iomsg,*) "GMTINY invalid or not set: ", self%GMTINY + iostat = -1 + return + end if + + if (param%lfragmentation) then + if (seed_set) then + call random_seed(put = param%seed) + else + call random_seed(get = param%seed) + end if + if (param%min_GMfrag < 0.0_DP) param%min_GMfrag = param%GMTINY + end if + + ! All reporting of collision information in SyMBA (including mergers) is now recorded in the Fraggle logfile + call io_log_start(param, FRAGGLE_LOG_OUT, "Fraggle logfile") + + if ((param%encounter_save /= "NONE") .and. & + (param%encounter_save /= "TRAJECTORY") .and. & + (param%encounter_save /= "CLOSEST") .and. & + (param%encounter_save /= "BOTH")) then + write(iomsg,*) 'Invalid encounter_save parameter: ',trim(adjustl(param%out_type)) + write(iomsg,*) 'Valid options are NONE, TRAJECTORY, CLOSEST, or BOTH' + iostat = -1 + return + end if + + param%lenc_save_trajectory = (param%encounter_save == "TRAJECTORY") .or. (param%encounter_save == "BOTH") + param%lenc_save_closest = (param%encounter_save == "CLOSEST") .or. (param%encounter_save == "BOTH") + integrator = v_list(1) - if ((integrator == RMVS) .or. (integrator == SYMBA)) then + if ((integrator == INT_RMVS) .or. (integrator == INT_SYMBA)) then if (.not.param%lclose) then write(iomsg,*) 'This integrator requires CHK_CLOSE to be enabled.' iostat = -1 @@ -785,7 +855,7 @@ module subroutine io_param_reader(self, unit, iotype, v_list, iostat, iomsg) ! Determine if the GR flag is set correctly for this integrator select case(integrator) - case(WHM, RMVS, HELIO, SYMBA) + case(INT_WHM, INT_RMVS, INT_HELIO, INT_SYMBA) case default if (param%lgr) write(iomsg, *) 'GR is not yet implemented for this integrator. This parameter will be ignored.' param%lgr = .false. @@ -803,7 +873,7 @@ module subroutine io_param_reader(self, unit, iotype, v_list, iostat, iomsg) param%ladaptive_interactions = .true. param%lflatten_interactions = .true. call io_log_start(param, INTERACTION_TIMER_LOG_OUT, "Interaction loop timer logfile") - call io_log_one_message(INTERACTION_TIMER_LOG_OUT, "Diagnostic values: loop style, time count, nplpl, metric") + call swiftest_io_log_one_message(INTERACTION_TIMER_LOG_OUT, "Diagnostic values: loop style, time count, nplpl, metric") case("TRIANGULAR") param%ladaptive_interactions = .false. param%lflatten_interactions = .false. @@ -818,7 +888,7 @@ module subroutine io_param_reader(self, unit, iotype, v_list, iostat, iomsg) param%ladaptive_interactions = .true. param%lflatten_interactions = .true. call io_log_start(param, INTERACTION_TIMER_LOG_OUT, "Interaction loop timer logfile") - call io_log_one_message(INTERACTION_TIMER_LOG_OUT, "Diagnostic values: loop style, time count, nplpl, metric") + call swiftest_io_log_one_message(INTERACTION_TIMER_LOG_OUT, "Diagnostic values: loop style, time count, nplpl, metric") end select select case(trim(adjustl(param%encounter_check_plpl))) @@ -826,7 +896,7 @@ module subroutine io_param_reader(self, unit, iotype, v_list, iostat, iomsg) param%ladaptive_encounters_plpl = .true. param%lencounter_sas_plpl = .true. call io_log_start(param, ENCOUNTER_PLPL_TIMER_LOG_OUT, "Encounter check loop timer logfile") - call io_log_one_message(ENCOUNTER_PLPL_TIMER_LOG_OUT, "Diagnostic values: loop style, time count, nplpl, metric") + call swiftest_io_log_one_message(ENCOUNTER_PLPL_TIMER_LOG_OUT, "Diagnostic values: loop style, time count, nplpl, metric") case("TRIANGULAR") param%ladaptive_encounters_plpl = .false. param%lencounter_sas_plpl = .false. @@ -841,7 +911,7 @@ module subroutine io_param_reader(self, unit, iotype, v_list, iostat, iomsg) param%ladaptive_encounters_plpl = .true. param%lencounter_sas_plpl = .true. call io_log_start(param, ENCOUNTER_PLPL_TIMER_LOG_OUT, "Encounter check loop timer logfile") - call io_log_one_message(ENCOUNTER_PLPL_TIMER_LOG_OUT, "Diagnostic values: loop style, time count, nplpl, metric") + call swiftest_io_log_one_message(ENCOUNTER_PLPL_TIMER_LOG_OUT, "Diagnostic values: loop style, time count, nplpl, metric") end select select case(trim(adjustl(param%encounter_check_pltp))) @@ -849,7 +919,7 @@ module subroutine io_param_reader(self, unit, iotype, v_list, iostat, iomsg) param%ladaptive_encounters_pltp = .true. param%lencounter_sas_pltp = .true. call io_log_start(param, ENCOUNTER_PLTP_TIMER_LOG_OUT, "Encounter check loop timer logfile") - call io_log_one_message(ENCOUNTER_PLTP_TIMER_LOG_OUT, "Diagnostic values: loop style, time count, npltp, metric") + call swiftest_io_log_one_message(ENCOUNTER_PLTP_TIMER_LOG_OUT, "Diagnostic values: loop style, time count, npltp, metric") case("TRIANGULAR") param%ladaptive_encounters_pltp = .false. param%lencounter_sas_pltp = .false. @@ -864,7 +934,7 @@ module subroutine io_param_reader(self, unit, iotype, v_list, iostat, iomsg) param%ladaptive_encounters_pltp = .true. param%lencounter_sas_pltp = .true. call io_log_start(param, ENCOUNTER_PLTP_TIMER_LOG_OUT, "Encounter check loop timer logfile") - call io_log_one_message(ENCOUNTER_PLTP_TIMER_LOG_OUT, "Diagnostic values: loop style, time count, npltp, metric") + call swiftest_io_log_one_message(ENCOUNTER_PLTP_TIMER_LOG_OUT, "Diagnostic values: loop style, time count, npltp, metric") end select iostat = 0 @@ -877,10 +947,10 @@ module subroutine io_param_reader(self, unit, iotype, v_list, iostat, iomsg) return 667 continue write(*,*) "Error reading param file: ", trim(adjustl(iomsg)) - end subroutine io_param_reader + end subroutine swiftest_io_param_reader - module subroutine io_param_writer(self, unit, iotype, v_list, iostat, iomsg) + module subroutine swiftest_io_param_writer(self, unit, iotype, v_list, iostat, iomsg) !! author: David A. Minton !! !! Dump integration parameters to file @@ -959,10 +1029,10 @@ module subroutine io_param_writer(self, unit, iotype, v_list, iostat, iomsg) 667 continue return - end subroutine io_param_writer + end subroutine swiftest_io_param_writer - module subroutine io_param_writer_one_char(param_name, param_value, unit) + module subroutine swiftest_io_param_writer_one_char(param_name, param_value, unit) !! author: David A. Minton !! !! Writes a single parameter name/value pair to a file unit. @@ -982,10 +1052,10 @@ module subroutine io_param_writer_one_char(param_name, param_value, unit) return 667 continue write(*,*) 'Error writing parameter: ',trim(adjustl(iomsg)) - end subroutine io_param_writer_one_char + end subroutine swiftest_io_param_writer_one_char - module subroutine io_param_writer_one_DP(param_name, param_value, unit) + module subroutine swiftest_io_param_writer_one_DP(param_name, param_value, unit) !! author: David A. Minton !! !! Writes a single parameter name/value pair to a file unit. @@ -1003,10 +1073,10 @@ module subroutine io_param_writer_one_DP(param_name, param_value, unit) call io_param_writer_one(param_name, param_value_string, unit) return - end subroutine io_param_writer_one_DP + end subroutine swiftest_io_param_writer_one_DP - module subroutine io_param_writer_one_DParr(param_name, param_value, unit) + module subroutine swiftest_io_param_writer_one_DParr(param_name, param_value, unit) !! author: David A. Minton !! !! Writes a single parameter name/value pair to a file unit. @@ -1035,10 +1105,10 @@ module subroutine io_param_writer_one_DParr(param_name, param_value, unit) call io_param_writer_one(param_name, param_value_string, unit) return - end subroutine io_param_writer_one_DParr + end subroutine swiftest_io_param_writer_one_DParr - module subroutine io_param_writer_one_I4B(param_name, param_value, unit) + module subroutine swiftest_io_param_writer_one_I4B(param_name, param_value, unit) !! author: David A. Minton !! !! Writes a single parameter name/value pair to a file unit. @@ -1056,10 +1126,10 @@ module subroutine io_param_writer_one_I4B(param_name, param_value, unit) call io_param_writer_one(param_name, param_value_string, unit) return - end subroutine io_param_writer_one_I4B + end subroutine swiftest_io_param_writer_one_I4B - module subroutine io_param_writer_one_I8B(param_name, param_value, unit) + module subroutine swiftest_io_param_writer_one_I8B(param_name, param_value, unit) !! author: David A. Minton !! !! Writes a single parameter name/value pair to a file unit. @@ -1077,10 +1147,10 @@ module subroutine io_param_writer_one_I8B(param_name, param_value, unit) call io_param_writer_one(param_name, param_value_string, unit) return - end subroutine io_param_writer_one_I8B + end subroutine swiftest_io_param_writer_one_I8B - module subroutine io_param_writer_one_I4Barr(param_name, param_value, unit) + module subroutine swiftest_io_param_writer_one_I4Barr(param_name, param_value, unit) !! author: David A. Minton !! !! Writes a single parameter name/value pair to a file unit. @@ -1109,10 +1179,10 @@ module subroutine io_param_writer_one_I4Barr(param_name, param_value, unit) call io_param_writer_one(param_name, param_value_string, unit) return - end subroutine io_param_writer_one_I4Barr + end subroutine swiftest_io_param_writer_one_I4Barr - module subroutine io_param_writer_one_logical(param_name, param_value, unit) + module subroutine swiftest_io_param_writer_one_logical(param_name, param_value, unit) !! author: David A. Minton !! !! Writes a single parameter name/value pair to a file unit. @@ -1130,10 +1200,10 @@ module subroutine io_param_writer_one_logical(param_name, param_value, unit) call io_param_writer_one(param_name, param_value_string, unit) return - end subroutine io_param_writer_one_logical + end subroutine swiftest_io_param_writer_one_logical - module subroutine io_param_writer_one_QP(param_name, param_value, unit) + module subroutine swiftest_io_param_writer_one_QP(param_name, param_value, unit) !! author: David A. Minton !! !! Writes a single parameter name/value pair to a file unit. @@ -1151,31 +1221,10 @@ module subroutine io_param_writer_one_QP(param_name, param_value, unit) call io_param_writer_one(param_name, param_value_string, unit) return - end subroutine io_param_writer_one_QP - - - module subroutine io_read_in_base(self,param) - !! author: Carlisle A. Wishard and David A. Minton - !! - !! Reads in either a central body, test particle, or massive body object. For the swiftest_body types (non-central body), it allocates array space for them - implicit none - class(swiftest_base), intent(inout) :: self !! Swiftest base object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - - if (param%in_type /= "ASCII") return ! This method is not used in NetCDF mode, as reading is done for the whole system, not on individual particle types - - select type(self) - class is (swiftest_body) - call io_read_in_body(self, param) - class is (swiftest_cb) - call io_read_in_cb(self, param) - end select - - return - end subroutine io_read_in_base + end subroutine swiftest_io_param_writer_one_QP - subroutine io_read_in_body(self, param) + module subroutine swiftest_io_read_in_body(self, param) !! author: The Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott !! !! Read in either test particle or massive body data @@ -1224,10 +1273,10 @@ subroutine io_read_in_body(self, param) 667 continue write(*,*) 'Error reading in initial conditions file: ',trim(adjustl(errmsg)) return - end subroutine io_read_in_body + end subroutine swiftest_io_read_in_body - subroutine io_read_in_cb(self, param) + module subroutine swiftest_io_read_in_cb(self, param) !! author: David A. Minton !! !! Reads in central body data @@ -1267,26 +1316,23 @@ subroutine io_read_in_cb(self, param) if (param%rmin < 0.0) param%rmin = self%radius - select type(cb => self) - class is (symba_cb) - cb%GM0 = cb%Gmass - cb%dGM = 0.0_DP - cb%R0 = cb%radius - if (param%lrotation) then - cb%L0(:) = cb%Ip(3) * cb%mass * cb%radius**2 * cb%rot(:) - cb%dL(:) = 0.0_DP - end if - end select + self%GM0 = self%Gmass + self%dGM = 0.0_DP + self%R0 = self%radius + if (param%lrotation) then + self%L0(:) = self%Ip(3) * self%mass * self%radius**2 * self%rot(:) + self%dL(:) = 0.0_DP + end if end if return 667 continue write(*,*) "Error reading central body file: " // trim(adjustl(errmsg)) call util_exit(FAILURE) - end subroutine io_read_in_cb + end subroutine swiftest_io_read_in_cb - module subroutine io_read_in_system(self, param) + module subroutine swiftest_io_read_in_system(self, param) !! author: David A. Minton and Carlisle A. Wishard !! !! Reads in the system from input files @@ -1331,16 +1377,16 @@ module subroutine io_read_in_system(self, param) end if return - end subroutine io_read_in_system + end subroutine swiftest_io_read_in_system - module function io_read_frame_body(self, iu, param) result(ierr) + module function swiftest_io_read_frame_body(self, iu, param) result(ierr) !! author: David A. Minton !! !! Reads a frame of output of either test particle or massive body data from a binary output file !! !! Adapted from David E. Kaufmann's Swifter routine io_read_frame.f90 - !! Adapted from Hal Levison's Swift routine io_read_frame.F + !! Adapted from Hal Levison's Swift routine io_read_frame.f implicit none ! Arguments class(swiftest_body), intent(inout) :: self !! Swiftest particle object @@ -1436,10 +1482,10 @@ module function io_read_frame_body(self, iu, param) result(ierr) write(*,*) "Error reading body file: " // trim(adjustl(errmsg)) end select call util_exit(FAILURE) - end function io_read_frame_body + end function swiftest_io_read_frame_body - module subroutine io_read_in_param(self, param_file_name) + module subroutine swiftest_io_read_in_param(self, param_file_name) !! author: David A. Minton !! !! Read in parameters for the integration @@ -1468,10 +1514,10 @@ module subroutine io_read_in_param(self, param_file_name) 667 continue write(self%display_unit,*) "Error reading parameter file: " // trim(adjustl(errmsg)) call util_exit(FAILURE) - end subroutine io_read_in_param + end subroutine swiftest_io_read_in_param - module subroutine io_set_display_param(self, display_style) + module subroutine swiftest_io_set_display_param(self, display_style) !! author: David A. Minton !! !! Sets the display style parameters. If display is "STANDARD" then output goes to stdout. If display is "COMPACT" @@ -1503,10 +1549,10 @@ module subroutine io_set_display_param(self, display_style) 667 continue write(*,*) "Error opening swiftest log file: " // trim(adjustl(errmsg)) call util_exit(FAILURE) - end subroutine io_set_display_param + end subroutine swiftest_io_set_display_param - module subroutine io_toupper(string) + module subroutine swiftest_io_toupper(string) !! author: David A. Minton !! !! Convert string to uppercase @@ -1528,17 +1574,40 @@ module subroutine io_toupper(string) end do return - end subroutine io_toupper + end subroutine swiftest_io_toupper + + + + module subroutine swiftest_io_write_discard(self, param) + !! author: David A. Minton + !! + !! Write the metadata of the discarded body to the output file + implicit none + class(swiftest_nbody_system), intent(inout) :: self !! SyMBA nbody system object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + ! Internals + + associate(pl => self%pl, npl => self%pl%nbody, pl_adds => self%pl_adds) + + if (self%tp_discards%nbody > 0) call self%tp_discards%write_info(param%system_history%nc, param) + if (self%pl_discards%nbody == 0) return + + call self%pl_discards%write_info(param%system_history%nc, param) + end associate + + return + + end subroutine swiftest_io_write_discard - module subroutine io_write_frame_system(self, param) + module subroutine swiftest_io_write_frame_system(self, param) !! author: The Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott !! !! Write a frame (header plus records for each massive body and active test particle) to output binary file !! There is no direct file output from this subroutine !! !! Adapted from David E. Kaufmann's Swifter routine io_write_frame.f90 - !! Adapted from Hal Levison's Swift routine io_write_frame.F + !! Adapted from Hal Levison's Swift routine io_write_frame.f implicit none ! Arguments class(swiftest_nbody_system), intent(inout) :: self !! Swiftest system object @@ -1582,6 +1651,6 @@ module subroutine io_write_frame_system(self, param) 667 continue write(*,*) "Error writing system frame: " // trim(adjustl(errmsg)) call util_exit(FAILURE) - end subroutine io_write_frame_system + end subroutine swiftest_io_write_frame_system end submodule s_io diff --git a/src/swiftest_procedures/swiftest_io_netcdf.f90 b/src/swiftest_procedures/swiftest_io_netcdf.f90 new file mode 100644 index 000000000..f9d48e366 --- /dev/null +++ b/src/swiftest_procedures/swiftest_io_netcdf.f90 @@ -0,0 +1,1211 @@ +!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh +!! This file is part of Swiftest. +!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License +!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. +!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty +!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. +!! You should have received a copy of the GNU General Public License along with Swiftest. +!! If not, see: https://www.gnu.org/licenses. + +submodule (swiftest) s_io_netcdf + use netcdf +contains + + + + module function swiftest_io_netcdf_get_old_t_final_system(self, param) result(old_t_final) + !! author: David A. Minton + !! + !! Validates the dump file to check whether the dump file initial conditions duplicate the last frame of the netcdf output. + !! + implicit none + ! Arguments + class(swiftest_nbody_system), intent(inout) :: self + class(base_parameters), intent(inout) :: param + ! Result + real(DP) :: old_t_final + ! Internals + integer(I4B) :: itmax, idmax + real(DP), dimension(:), allocatable :: vals + real(DP), dimension(1) :: rtemp + real(DP), dimension(NDIM) :: rot0, Ip0, Lnow + real(DP) :: KE_orb_orig, KE_spin_orig, PE_orig + + select type(param) + class is (swiftest_parameters) + associate (nc => param%system_history%nc, cb => self%cb) + call nc%open(param) + call netcdf_check( nf90_inquire_dimension(nc%id, nc%time_dimid, len=itmax), "swiftest_io_netcdf_get_old_t_final_system time_dimid" ) + call netcdf_check( nf90_inquire_dimension(nc%id, nc%name_dimid, len=idmax), "swiftest_io_netcdf_get_old_t_final_system name_dimid" ) + allocate(vals(idmax)) + call netcdf_check( nf90_get_var(nc%id, nc%time_varid, rtemp, start=[1], count=[1]), "swiftest_io_netcdf_get_old_t_final_system time_varid" ) + + !old_t_final = rtemp(1) + old_t_final = param%t0 ! For NetCDF it is safe to overwrite the final t value on a restart + + if (param%lenergy) then + call netcdf_check( nf90_get_var(nc%id, nc%KE_orb_varid, rtemp, start=[1], count=[1]), "swiftest_io_netcdf_get_old_t_final_system KE_orb_varid" ) + KE_orb_orig = rtemp(1) + + call netcdf_check( nf90_get_var(nc%id, nc%KE_spin_varid, rtemp, start=[1], count=[1]), "swiftest_io_netcdf_get_old_t_final_system KE_spin_varid" ) + KE_spin_orig = rtemp(1) + + call netcdf_check( nf90_get_var(nc%id, nc%PE_varid, rtemp, start=[1], count=[1]), "swiftest_io_netcdf_get_old_t_final_system PE_varid" ) + PE_orig = rtemp(1) + + call netcdf_check( nf90_get_var(nc%id, nc%Ecollisions_varid, self%Ecollisions, start=[1]), "swiftest_io_netcdf_get_old_t_final_system Ecollisions_varid" ) + call netcdf_check( nf90_get_var(nc%id, nc%Euntracked_varid, self%Euntracked, start=[1]), "swiftest_io_netcdf_get_old_t_final_system Euntracked_varid" ) + + self%Eorbit_orig = KE_orb_orig + KE_spin_orig + PE_orig + self%Ecollisions + self%Euntracked + + call netcdf_check( nf90_get_var(nc%id, nc%L_orb_varid, self%Lorbit_orig(:), start=[1,1], count=[NDIM,1]), "swiftest_io_netcdf_get_old_t_final_system L_orb_varid" ) + call netcdf_check( nf90_get_var(nc%id, nc%Lspin_varid, self%Lspin_orig(:), start=[1,1], count=[NDIM,1]), "swiftest_io_netcdf_get_old_t_final_system Lspin_varid" ) + call netcdf_check( nf90_get_var(nc%id, nc%L_escape_varid, self%Lescape(:), start=[1,1], count=[NDIM,1]), "swiftest_io_netcdf_get_old_t_final_system L_escape_varid" ) + + self%Ltot_orig(:) = self%Lorbit_orig(:) + self%Lspin_orig(:) + self%Lescape(:) + + call netcdf_check( nf90_get_var(nc%id, nc%Gmass_varid, vals, start=[1,1], count=[idmax,1]), "swiftest_io_netcdf_get_old_t_final_system Gmass_varid" ) + call netcdf_check( nf90_get_var(nc%id, nc%GMescape_varid, self%GMescape, start=[1]), "swiftest_io_netcdf_get_old_t_final_system GMescape_varid" ) + self%GMtot_orig = vals(1) + sum(vals(2:idmax), vals(2:idmax) == vals(2:idmax)) + self%GMescape + + cb%GM0 = vals(1) + cb%dGM = cb%Gmass - cb%GM0 + + call netcdf_check( nf90_get_var(nc%id, nc%radius_varid, rtemp, start=[1,1], count=[1,1]), "swiftest_io_netcdf_get_old_t_final_system radius_varid" ) + cb%R0 = rtemp(1) + + if (param%lrotation) then + + call netcdf_check( nf90_get_var(nc%id, nc%rot_varid, rot0, start=[1,1,1], count=[NDIM,1,1]), "swiftest_io_netcdf_get_old_t_final_system rot_varid" ) + call netcdf_check( nf90_get_var(nc%id, nc%Ip_varid, Ip0, start=[1,1,1], count=[NDIM,1,1]), "swiftest_io_netcdf_get_old_t_final_system Ip_varid" ) + + cb%L0(:) = Ip0(3) * cb%GM0 * cb%R0**2 * rot0(:) + + Lnow(:) = cb%Ip(3) * cb%Gmass * cb%radius**2 * cb%rot(:) + cb%dL(:) = Lnow(:) - cb%L0(:) + end if + + end if + + deallocate(vals) + end associate + end select + + return + end function swiftest_io_netcdf_get_old_t_final_system + + + module subroutine swiftest_io_netcdf_initialize_output(self, param) + !! author: Carlisle A. Wishard, Dana Singh, and David A. Minton + !! + !! Initialize a NetCDF file system and defines all variables. + use, intrinsic :: ieee_arithmetic + implicit none + ! Arguments + class(swiftest_io_netcdf_parameters), intent(inout) :: self !! Parameters used to for writing a NetCDF dataset to file + class(base_parameters), intent(in) :: param !! Current run configuration parameters + ! Internals + integer(I4B) :: nvar, varid, vartype + real(DP) :: dfill + real(SP) :: sfill + integer(I4B), parameter :: NO_FILL = 0 + logical :: fileExists + character(len=STRMAX) :: errmsg + integer(I4B) :: ndims + + associate(nc => self) + + dfill = ieee_value(dfill, IEEE_QUIET_NAN) + sfill = ieee_value(sfill, IEEE_QUIET_NAN) + + select case (param%out_type) + case("swiftest_io_netcdf_FLOAT") + nc%out_type = NF90_FLOAT + case("swiftest_io_netcdf_DOUBLE") + nc%out_type = NF90_DOUBLE + end select + + ! Check if the file exists, and if it does, delete it + inquire(file=nc%file_name, exist=fileExists) + if (fileExists) then + open(unit=LUN, file=nc%file_name, status="old", err=667, iomsg=errmsg) + close(unit=LUN, status="delete") + end if + + ! Create the file + call netcdf_check( nf90_create(nc%file_name, NF90io_netcdf4, nc%id), "swiftest_io_netcdf_initialize_output nf90_create" ) + + ! Dimensions + call netcdf_check( nf90_def_dim(nc%id, nc%time_dimname, NF90_UNLIMITED, nc%time_dimid), "swiftest_io_netcdf_initialize_output nf90_def_dim time_dimid" ) ! Simulation time dimension + call netcdf_check( nf90_def_dim(nc%id, nc%space_dimname, NDIM, nc%space_dimid), "swiftest_io_netcdf_initialize_output nf90_def_dim space_dimid" ) ! 3D space dimension + call netcdf_check( nf90_def_dim(nc%id, nc%name_dimname, NF90_UNLIMITED, nc%name_dimid), "swiftest_io_netcdf_initialize_output nf90_def_dim name_dimid" ) ! dimension to store particle id numbers + call netcdf_check( nf90_def_dim(nc%id, nc%str_dimname, NAMELEN, nc%str_dimid), "swiftest_io_netcdf_initialize_output nf90_def_dim str_dimid" ) ! Dimension for string variables (aka character arrays) + + ! Dimension coordinates + call netcdf_check( nf90_def_var(nc%id, nc%time_dimname, nc%out_type, nc%time_dimid, nc%time_varid), "swiftest_io_netcdf_initialize_output nf90_def_var time_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%space_dimname, NF90_CHAR, nc%space_dimid, nc%space_varid), "swiftest_io_netcdf_initialize_output nf90_def_var space_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%name_dimname, NF90_CHAR, [nc%str_dimid, nc%name_dimid], nc%name_varid), "swiftest_io_netcdf_initialize_output nf90_def_var name_varid" ) + + ! Variables + call netcdf_check( nf90_def_var(nc%id, nc%id_varname, NF90_INT, nc%name_dimid, nc%id_varid), "swiftest_io_netcdf_initialize_output nf90_def_var id_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%npl_varname, NF90_INT, nc%time_dimid, nc%npl_varid), "swiftest_io_netcdf_initialize_output nf90_def_var npl_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%ntp_varname, NF90_INT, nc%time_dimid, nc%ntp_varid), "swiftest_io_netcdf_initialize_output nf90_def_var ntp_varid" ) + if (param%integrator == INT_SYMBA) call netcdf_check( nf90_def_var(nc%id, nc%nplm_varname, NF90_INT, nc%time_dimid, nc%nplm_varid), "swiftest_io_netcdf_initialize_output nf90_def_var nplm_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%ptype_varname, NF90_CHAR, [nc%str_dimid, nc%name_dimid], nc%ptype_varid), "swiftest_io_netcdf_initialize_output nf90_def_var ptype_varid" ) + + if ((param%out_form == "XV") .or. (param%out_form == "XVEL")) then + call netcdf_check( nf90_def_var(nc%id, nc%rh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%rh_varid), "swiftest_io_netcdf_initialize_output nf90_def_var rh_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%vh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%vh_varid), "swiftest_io_netcdf_initialize_output nf90_def_var vh_varid" ) + + !! When GR is enabled, we need to save the pseudovelocity vectors in addition to the true heliocentric velocity vectors, otherwise + !! we cannnot expect bit-identical runs from restarted runs with GR enabled due to floating point errors during the conversion. + if (param%lgr) then + call netcdf_check( nf90_def_var(nc%id, nc%gr_pseudo_vh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%gr_pseudo_vh_varid), "swiftest_io_netcdf_initialize_output nf90_def_var gr_psuedo_vh_varid" ) + nc%lpseudo_vel_exists = .true. + end if + + end if + + if ((param%out_form == "EL") .or. (param%out_form == "XVEL")) then + call netcdf_check( nf90_def_var(nc%id, nc%a_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%a_varid), "swiftest_io_netcdf_initialize_output nf90_def_var a_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%e_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%e_varid), "swiftest_io_netcdf_initialize_output nf90_def_var e_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%inc_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%inc_varid), "swiftest_io_netcdf_initialize_output nf90_def_var inc_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%capom_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%capom_varid), "swiftest_io_netcdf_initialize_output nf90_def_var capom_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%omega_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%omega_varid), "swiftest_io_netcdf_initialize_output nf90_def_var omega_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%capm_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%capm_varid), "swiftest_io_netcdf_initialize_output nf90_def_var capm_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%varpi_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%varpi_varid), "swiftest_io_netcdf_initialize_output nf90_def_var varpi_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%lam_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%lam_varid), "swiftest_io_netcdf_initialize_output nf90_def_var lam_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%f_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%f_varid), "swiftest_io_netcdf_initialize_output nf90_def_var f_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%cape_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%cape_varid), "swiftest_io_netcdf_initialize_output nf90_def_var cape_varid" ) + end if + + call netcdf_check( nf90_def_var(nc%id, nc%gmass_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%Gmass_varid), "swiftest_io_netcdf_initialize_output nf90_def_var Gmass_varid" ) + + if (param%lrhill_present) then + call netcdf_check( nf90_def_var(nc%id, nc%rhill_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%rhill_varid), "swiftest_io_netcdf_initialize_output nf90_def_var rhill_varid" ) + end if + + if (param%lclose) then + call netcdf_check( nf90_def_var(nc%id, nc%radius_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%radius_varid), "swiftest_io_netcdf_initialize_output nf90_def_var radius_varid" ) + + call netcdf_check( nf90_def_var(nc%id, nc%origin_time_varname, nc%out_type, nc%name_dimid, nc%origin_time_varid), "swiftest_io_netcdf_initialize_output nf90_def_var origin_time_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%origin_type_varname, NF90_CHAR, [nc%str_dimid, nc%name_dimid], & + nc%origin_type_varid), "swiftest_io_netcdf_initialize_output nf90_create" ) + call netcdf_check( nf90_def_var(nc%id, nc%origin_rh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid], nc%origin_rh_varid), "swiftest_io_netcdf_initialize_output nf90_def_var origin_rh_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%origin_vh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid], nc%origin_vh_varid), "swiftest_io_netcdf_initialize_output nf90_def_var origin_vh_varid" ) + + call netcdf_check( nf90_def_var(nc%id, nc%collision_id_varname, NF90_INT, nc%name_dimid, nc%collision_id_varid), "swiftest_io_netcdf_initialize_output nf90_def_var collision_id_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%discard_time_varname, nc%out_type, nc%name_dimid, nc%discard_time_varid), "swiftest_io_netcdf_initialize_output nf90_def_var discard_time_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%discard_rh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid], nc%discard_rh_varid), "swiftest_io_netcdf_initialize_output nf90_def_var discard_rh_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%discard_vh_varname, nc%out_type, [nc%space_dimid, nc%name_dimid], nc%discard_vh_varid), "swiftest_io_netcdf_initialize_output nf90_def_var discard_vh_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%discard_body_id_varname, NF90_INT, nc%name_dimid, nc%discard_body_id_varid), "swiftest_io_netcdf_initialize_output nf90_def_var discard_body_id_varid" ) + end if + + if (param%lrotation) then + call netcdf_check( nf90_def_var(nc%id, nc%Ip_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%Ip_varid), "swiftest_io_netcdf_initialize_output nf90_def_var Ip_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%rot_varname, nc%out_type, [nc%space_dimid, nc%name_dimid, nc%time_dimid], nc%rot_varid), "swiftest_io_netcdf_initialize_output nf90_def_var rot_varid" ) + end if + + ! if (param%ltides) then + ! call netcdf_check( nf90_def_var(nc%id, nc%k2_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%k2_varid), "swiftest_io_netcdf_initialize_output nf90_def_var k2_varid" ) + ! call netcdf_check( nf90_def_var(nc%id, nc%q_varname, nc%out_type, [nc%name_dimid, nc%time_dimid], nc%Q_varid), "swiftest_io_netcdf_initialize_output nf90_def_var Q_varid" ) + ! end if + + if (param%lenergy) then + call netcdf_check( nf90_def_var(nc%id, nc%ke_orb_varname, nc%out_type, nc%time_dimid, nc%KE_orb_varid), "swiftest_io_netcdf_initialize_output nf90_def_var KE_orb_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%ke_spin_varname, nc%out_type, nc%time_dimid, nc%KE_spin_varid), "swiftest_io_netcdf_initialize_output nf90_def_var KE_spin_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%pe_varname, nc%out_type, nc%time_dimid, nc%PE_varid), "swiftest_io_netcdf_initialize_output nf90_def_var PE_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%L_orb_varname, nc%out_type, [nc%space_dimid, nc%time_dimid], nc%L_orb_varid), "swiftest_io_netcdf_initialize_output nf90_def_var L_orb_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%Lspin_varname, nc%out_type, [nc%space_dimid, nc%time_dimid], nc%Lspin_varid), "swiftest_io_netcdf_initialize_output nf90_def_var Lspin_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%L_escape_varname, nc%out_type, [nc%space_dimid, nc%time_dimid], nc%L_escape_varid), "swiftest_io_netcdf_initialize_output nf90_def_var L_escape_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%Ecollisions_varname, nc%out_type, nc%time_dimid, nc%Ecollisions_varid), "swiftest_io_netcdf_initialize_output nf90_def_var Ecollisions_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%Euntracked_varname, nc%out_type, nc%time_dimid, nc%Euntracked_varid), "swiftest_io_netcdf_initialize_output nf90_def_var Euntracked_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%GMescape_varname, nc%out_type, nc%time_dimid, nc%GMescape_varid), "swiftest_io_netcdf_initialize_output nf90_def_var GMescape_varid" ) + end if + + call netcdf_check( nf90_def_var(nc%id, nc%j2rp2_varname, nc%out_type, nc%time_dimid, nc%j2rp2_varid), "swiftest_io_netcdf_initialize_output nf90_def_var j2rp2_varid" ) + call netcdf_check( nf90_def_var(nc%id, nc%j4rp4_varname, nc%out_type, nc%time_dimid, nc%j4rp4_varid), "swiftest_io_netcdf_initialize_output nf90_def_var j4rp4_varid" ) + + + ! Set fill mode to NaN for all variables + call netcdf_check( nf90_inquire(nc%id, nVariables=nvar), "swiftest_io_netcdf_initialize_output nf90_inquire nVariables" ) + do varid = 1, nvar + call netcdf_check( nf90_inquire_variable(nc%id, varid, xtype=vartype, ndims=ndims), "swiftest_io_netcdf_initialize_output nf90_inquire_variable" ) + select case(vartype) + case(NF90_INT) + call netcdf_check( nf90_def_var_fill(nc%id, varid, NO_FILL, NF90_FILL_INT), "swiftest_io_netcdf_initialize_output nf90_def_var_fill NF90_INT" ) + case(NF90_FLOAT) + call netcdf_check( nf90_def_var_fill(nc%id, varid, NO_FILL, sfill), "swiftest_io_netcdf_initialize_output nf90_def_var_fill NF90_FLOAT" ) + case(NF90_DOUBLE) + call netcdf_check( nf90_def_var_fill(nc%id, varid, NO_FILL, dfill), "swiftest_io_netcdf_initialize_output nf90_def_var_fill NF90_DOUBLE" ) + case(NF90_CHAR) + call netcdf_check( nf90_def_var_fill(nc%id, varid, NO_FILL, 0), "swiftest_io_netcdf_initialize_output nf90_def_var_fill NF90_CHAR" ) + end select + end do + + ! Set special fill mode for discard time so that we can make use of it for non-discarded bodies. + select case (vartype) + case(NF90_FLOAT) + call netcdf_check( nf90_def_var_fill(nc%id, nc%discard_time_varid, NO_FILL, huge(1.0_SP)), "swiftest_io_netcdf_initialize_output nf90_def_var_fill discard_time NF90_FLOAT" ) + case(NF90_DOUBLE) + call netcdf_check( nf90_def_var_fill(nc%id, nc%discard_time_varid, NO_FILL, huge(1.0_DP)), "swiftest_io_netcdf_initialize_output nf90_def_var_fill discard_time NF90_DOUBLE" ) + end select + + ! Take the file out of define mode + call netcdf_check( nf90_enddef(nc%id), "swiftest_io_netcdf_initialize_output nf90_enddef" ) + + ! Add in the space dimension coordinates + call netcdf_check( nf90_put_var(nc%id, nc%space_varid, nc%space_coords, start=[1], count=[NDIM]), "swiftest_io_netcdf_initialize_output nf90_put_var space" ) + + end associate + return + + 667 continue + write(*,*) "Error creating NetCDF output file. " // trim(adjustl(errmsg)) + call util_exit(FAILURE) + end subroutine swiftest_io_netcdf_initialize_output + + + module subroutine swiftest_io_netcdf_open(self, param, readonly) + !! author: Carlisle A. Wishard, Dana Singh, and David A. Minton + !! + !! Opens a NetCDF file and does the variable inquiries to activate variable ids + implicit none + ! Arguments + class(swiftest_io_netcdf_parameters), intent(inout) :: self !! Parameters used to identify a particular NetCDF dataset + class(base_parameters), intent(in) :: param !! Current run configuration parameters + logical, optional, intent(in) :: readonly !! Logical flag indicating that this should be open read only + ! Internals + integer(I4B) :: mode, status + character(len=STRMAX) :: errmsg + + mode = NF90_WRITE + if (present(readonly)) then + if (readonly) mode = NF90_NOWRITE + end if + + associate(nc => self) + + write(errmsg,*) "swiftest_io_netcdf_open nf90_open ",trim(adjustl(nc%file_name)) + call netcdf_check( nf90_open(nc%file_name, mode, nc%id), errmsg) + + ! Dimensions + call netcdf_check( nf90_inq_dimid(nc%id, nc%time_dimname, nc%time_dimid), "swiftest_io_netcdf_open nf90_inq_dimid time_dimid" ) + call netcdf_check( nf90_inq_dimid(nc%id, nc%space_dimname, nc%space_dimid), "swiftest_io_netcdf_open nf90_inq_dimid space_dimid" ) + call netcdf_check( nf90_inq_dimid(nc%id, nc%name_dimname, nc%name_dimid), "swiftest_io_netcdf_open nf90_inq_dimid name_dimid" ) + call netcdf_check( nf90_inq_dimid(nc%id, nc%str_dimname, nc%str_dimid), "swiftest_io_netcdf_open nf90_inq_dimid str_dimid" ) + + ! Dimension coordinates + call netcdf_check( nf90_inq_varid(nc%id, nc%time_dimname, nc%time_varid), "swiftest_io_netcdf_open nf90_inq_varid time_varid" ) + call netcdf_check( nf90_inq_varid(nc%id, nc%space_dimname, nc%space_varid), "swiftest_io_netcdf_open nf90_inq_varid space_varid" ) + call netcdf_check( nf90_inq_varid(nc%id, nc%name_dimname, nc%name_varid), "swiftest_io_netcdf_open nf90_inq_varid name_varid" ) + + ! Required Variables + call netcdf_check( nf90_inq_varid(nc%id, nc%id_varname, nc%id_varid), "swiftest_io_netcdf_open nf90_inq_varid name_varid" ) + call netcdf_check( nf90_inq_varid(nc%id, nc%gmass_varname, nc%Gmass_varid), "swiftest_io_netcdf_open nf90_inq_varid Gmass_varid" ) + + if ((param%out_form == "XV") .or. (param%out_form == "XVEL")) then + call netcdf_check( nf90_inq_varid(nc%id, nc%rh_varname, nc%rh_varid), "swiftest_io_netcdf_open nf90_inq_varid rh_varid" ) + call netcdf_check( nf90_inq_varid(nc%id, nc%vh_varname, nc%vh_varid), "swiftest_io_netcdf_open nf90_inq_varid vh_varid" ) + + if (param%lgr) then + !! check if pseudovelocity vectors exist in this file. If they are, set the correct flag so we know whe should not do the conversion. + status = nf90_inq_varid(nc%id, nc%gr_pseudo_vh_varname, nc%gr_pseudo_vh_varid) + nc%lpseudo_vel_exists = (status == nf90_noerr) + if (param%lrestart .and. .not.nc%lpseudo_vel_exists) then + write(*,*) "Warning! Pseudovelocity not found in input file for GR enabled run. If this is a restarted run, bit-identical trajectories are not guarunteed!" + end if + + end if + end if + + if ((param%out_form == "EL") .or. (param%out_form == "XVEL")) then + call netcdf_check( nf90_inq_varid(nc%id, nc%a_varname, nc%a_varid), "swiftest_io_netcdf_open nf90_inq_varid a_varid" ) + call netcdf_check( nf90_inq_varid(nc%id, nc%e_varname, nc%e_varid), "swiftest_io_netcdf_open nf90_inq_varid e_varid" ) + call netcdf_check( nf90_inq_varid(nc%id, nc%inc_varname, nc%inc_varid), "swiftest_io_netcdf_open nf90_inq_varid inc_varid" ) + call netcdf_check( nf90_inq_varid(nc%id, nc%capom_varname, nc%capom_varid), "swiftest_io_netcdf_open nf90_inq_varid capom_varid" ) + call netcdf_check( nf90_inq_varid(nc%id, nc%omega_varname, nc%omega_varid), "swiftest_io_netcdf_open nf90_inq_varid omega_varid" ) + call netcdf_check( nf90_inq_varid(nc%id, nc%capm_varname, nc%capm_varid), "swiftest_io_netcdf_open nf90_inq_varid capm_varid" ) + end if + + if (param%lclose) then + call netcdf_check( nf90_inq_varid(nc%id, nc%radius_varname, nc%radius_varid), "swiftest_io_netcdf_open nf90_inq_varid radius_varid" ) + end if + + if (param%lrotation) then + call netcdf_check( nf90_inq_varid(nc%id, nc%Ip_varname, nc%Ip_varid), "swiftest_io_netcdf_open nf90_inq_varid Ip_varid" ) + call netcdf_check( nf90_inq_varid(nc%id, nc%rot_varname, nc%rot_varid), "swiftest_io_netcdf_open nf90_inq_varid rot_varid" ) + end if + + ! if (param%ltides) then + ! call netcdf_check( nf90_inq_varid(nc%id, nc%k2_varname, nc%k2_varid), "swiftest_io_netcdf_open nf90_inq_varid k2_varid" ) + ! call netcdf_check( nf90_inq_varid(nc%id, nc%q_varname, nc%Q_varid), "swiftest_io_netcdf_open nf90_inq_varid Q_varid" ) + ! end if + + ! Optional Variables + if (param%lrhill_present) then + status = nf90_inq_varid(nc%id, nc%rhill_varname, nc%rhill_varid) + if (status /= nf90_noerr) write(*,*) "Warning! RHILL variable not set in input file. Calculating." + end if + + ! Optional variables The User Doesn't Need to Know About + status = nf90_inq_varid(nc%id, nc%npl_varname, nc%npl_varid) + status = nf90_inq_varid(nc%id, nc%ntp_varname, nc%ntp_varid) + status = nf90_inq_varid(nc%id, nc%j2rp2_varname, nc%j2rp2_varid) + status = nf90_inq_varid(nc%id, nc%j4rp4_varname, nc%j4rp4_varid) + status = nf90_inq_varid(nc%id, nc%ptype_varname, nc%ptype_varid) + status = nf90_inq_varid(nc%id, nc%varpi_varname, nc%varpi_varid) + status = nf90_inq_varid(nc%id, nc%lam_varname, nc%lam_varid) + status = nf90_inq_varid(nc%id, nc%f_varname, nc%f_varid) + status = nf90_inq_varid(nc%id, nc%cape_varname, nc%cape_varid) + + if (param%integrator == INT_SYMBA) then + status = nf90_inq_varid(nc%id, nc%nplm_varname, nc%nplm_varid) + end if + + if (param%lclose) then + status = nf90_inq_varid(nc%id, nc%origin_type_varname, nc%origin_type_varid) + status = nf90_inq_varid(nc%id, nc%origin_time_varname, nc%origin_time_varid) + status = nf90_inq_varid(nc%id, nc%origin_rh_varname, nc%origin_rh_varid) + status = nf90_inq_varid(nc%id, nc%origin_vh_varname, nc%origin_vh_varid) + status = nf90_inq_varid(nc%id, nc%collision_id_varname, nc%collision_id_varid) + status = nf90_inq_varid(nc%id, nc%discard_time_varname, nc%discard_time_varid) + status = nf90_inq_varid(nc%id, nc%discard_rh_varname, nc%discard_rh_varid) + status = nf90_inq_varid(nc%id, nc%discard_vh_varname, nc%discard_vh_varid) + status = nf90_inq_varid(nc%id, nc%discard_body_id_varname, nc%discard_body_id_varid) + end if + + if (param%lenergy) then + status = nf90_inq_varid(nc%id, nc%ke_orb_varname, nc%KE_orb_varid) + status = nf90_inq_varid(nc%id, nc%ke_spin_varname, nc%KE_spin_varid) + status = nf90_inq_varid(nc%id, nc%pe_varname, nc%PE_varid) + status = nf90_inq_varid(nc%id, nc%L_orb_varname, nc%L_orb_varid) + status = nf90_inq_varid(nc%id, nc%Lspin_varname, nc%Lspin_varid) + status = nf90_inq_varid(nc%id, nc%L_escape_varname, nc%L_escape_varid) + status = nf90_inq_varid(nc%id, nc%Ecollisions_varname, nc%Ecollisions_varid) + status = nf90_inq_varid(nc%id, nc%Euntracked_varname, nc%Euntracked_varid) + status = nf90_inq_varid(nc%id, nc%GMescape_varname, nc%GMescape_varid) + end if + + end associate + + return + end subroutine swiftest_io_netcdf_open + + + module function swiftest_io_netcdf_read_frame_system(self, nc, param) result(ierr) + !! author: The Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott + !! + !! Read a frame (header plus records for each massive body and active test particle) from an output binary file + implicit none + ! Arguments + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest system object + class(base_io_netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular NetCDF dataset + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + ! Return + integer(I4B) :: ierr !! Error code: returns 0 if the read is successful + ! Internals + integer(I4B) :: i, tslot, idmax, npl_check, ntp_check, nplm_check, t_max, str_max, status + real(DP), dimension(:), allocatable :: rtemp + real(DP), dimension(:,:), allocatable :: vectemp + integer(I4B), dimension(:), allocatable :: itemp + logical, dimension(:), allocatable :: validmask, tpmask, plmask + + tslot = param%ioutput + + call nc%open(param, readonly=.true.) + call self%read_hdr(nc, param) + select type(param) + class is (swiftest_parameters) + associate(cb => self%cb, pl => self%pl, tp => self%tp, npl => self%pl%nbody, ntp => self%tp%nbody) + + call pl%setup(npl, param) + call tp%setup(ntp, param) + + call netcdf_check( nf90_inquire_dimension(nc%id, nc%name_dimid, len=idmax), "swiftest_io_netcdf_read_frame_system nf90_inquire_dimension name_dimid" ) + allocate(rtemp(idmax)) + allocate(vectemp(NDIM,idmax)) + allocate(itemp(idmax)) + allocate(validmask(idmax)) + allocate(tpmask(idmax)) + allocate(plmask(idmax)) + call netcdf_check( nf90_inquire_dimension(nc%id, nc%time_dimid, len=t_max), "swiftest_io_netcdf_read_frame_system nf90_inquire_dimension time_dimid" ) + call netcdf_check( nf90_inquire_dimension(nc%id, nc%str_dimid, len=str_max), "swiftest_io_netcdf_read_frame_system nf90_inquire_dimension str_dimid" ) + + ! First filter out only the id slots that contain valid bodies + if (param%in_form == "XV") then + call netcdf_check( nf90_get_var(nc%id, nc%rh_varid, vectemp(:,:), start=[1, 1, tslot]), "swiftest_io_netcdf_read_frame_system filter pass nf90_getvar rh_varid" ) + validmask(:) = vectemp(1,:) == vectemp(1,:) + else + call netcdf_check( nf90_get_var(nc%id, nc%a_varid, rtemp(:), start=[1, tslot]), "swiftest_io_netcdf_read_frame_system filter pass nf90_getvar a_varid" ) + validmask(:) = rtemp(:) == rtemp(:) + end if + + ! Next, filter only bodies that don't have mass (test particles) + call netcdf_check( nf90_get_var(nc%id, nc%Gmass_varid, rtemp(:), start=[1, tslot]), "swiftest_io_netcdf_read_frame_system nf90_getvar tp finder Gmass_varid" ) + plmask(:) = rtemp(:) == rtemp(:) .and. validmask(:) + tpmask(:) = .not. plmask(:) .and. validmask(:) + plmask(1) = .false. ! This is the central body + + ! Check to make sure the number of bodies is correct + npl_check = count(plmask(:)) + ntp_check = count(tpmask(:)) + + if (npl_check /= npl) then + write(*,*) "Error reading in NetCDF file: The recorded value of npl does not match the number of active massive bodies" + call util_exit(failure) + end if + + if (ntp_check /= ntp) then + write(*,*) "Error reading in NetCDF file: The recorded value of ntp does not match the number of active test particles" + call util_exit(failure) + end if + + if (param%integrator == INT_SYMBA) then + nplm_check = count(pack(rtemp,plmask) > param%GMTINY ) + if (nplm_check /= pl%nplm) then + write(*,*) "Error reading in NetCDF file: The recorded value of nplm does not match the number of active fully interacting massive bodies" + call util_exit(failure) + end if + end if + + ! Now read in each variable and split the outputs by body type + if ((param%in_form == "XV") .or. (param%in_form == "XVEL")) then + call netcdf_check( nf90_get_var(nc%id, nc%rh_varid, vectemp, start=[1, 1, tslot], count=[NDIM,idmax,1]), "swiftest_io_netcdf_read_frame_system nf90_getvar rh_varid" ) + do i = 1, NDIM + if (npl > 0) pl%rh(i,:) = pack(vectemp(i,:), plmask(:)) + if (ntp > 0) tp%rh(i,:) = pack(vectemp(i,:), tpmask(:)) + end do + + if (param%lgr .and. nc%lpseudo_vel_exists) then + call netcdf_check( nf90_get_var(nc%id, nc%gr_pseudo_vh_varid, vectemp, start=[1, 1, tslot], count=[NDIM,idmax,1]), "swiftest_io_netcdf_read_frame_system nf90_getvar gr_pseudo_vh_varid" ) + do i = 1, NDIM + if (npl > 0) pl%vh(i,:) = pack(vectemp(i,:), plmask(:)) + if (ntp > 0) tp%vh(i,:) = pack(vectemp(i,:), tpmask(:)) + end do + else + call netcdf_check( nf90_get_var(nc%id, nc%vh_varid, vectemp, start=[1, 1, tslot], count=[NDIM,idmax,1]), "swiftest_io_netcdf_read_frame_system nf90_getvar vh_varid" ) + do i = 1, NDIM + if (npl > 0) pl%vh(i,:) = pack(vectemp(i,:), plmask(:)) + if (ntp > 0) tp%vh(i,:) = pack(vectemp(i,:), tpmask(:)) + end do + end if + end if + + if ((param%in_form == "EL") .or. (param%in_form == "XVEL")) then + call netcdf_check( nf90_get_var(nc%id, nc%a_varid, rtemp, start=[1, tslot], count=[idmax,1]), "swiftest_io_netcdf_read_frame_system nf90_getvar a_varid" ) + if (.not.allocated(pl%a)) allocate(pl%a(npl)) + if (.not.allocated(tp%a)) allocate(tp%a(ntp)) + if (npl > 0) pl%a(:) = pack(rtemp, plmask) + if (ntp > 0) tp%a(:) = pack(rtemp, tpmask) + + call netcdf_check( nf90_get_var(nc%id, nc%e_varid, rtemp, start=[1, tslot], count=[idmax,1]), "swiftest_io_netcdf_read_frame_system nf90_getvar e_varid" ) + if (.not.allocated(pl%e)) allocate(pl%e(npl)) + if (.not.allocated(tp%e)) allocate(tp%e(ntp)) + if (npl > 0) pl%e(:) = pack(rtemp, plmask) + if (ntp > 0) tp%e(:) = pack(rtemp, tpmask) + + call netcdf_check( nf90_get_var(nc%id, nc%inc_varid, rtemp, start=[1, tslot], count=[idmax,1]), "swiftest_io_netcdf_read_frame_system nf90_getvar inc_varid" ) + rtemp = rtemp * DEG2RAD + if (.not.allocated(pl%inc)) allocate(pl%inc(npl)) + if (.not.allocated(tp%inc)) allocate(tp%inc(ntp)) + if (npl > 0) pl%inc(:) = pack(rtemp, plmask) + if (ntp > 0) tp%inc(:) = pack(rtemp, tpmask) + + call netcdf_check( nf90_get_var(nc%id, nc%capom_varid, rtemp, start=[1, tslot], count=[idmax,1]), "swiftest_io_netcdf_read_frame_system nf90_getvar capom_varid" ) + rtemp = rtemp * DEG2RAD + if (.not.allocated(pl%capom)) allocate(pl%capom(npl)) + if (.not.allocated(tp%capom)) allocate(tp%capom(ntp)) + if (npl > 0) pl%capom(:) = pack(rtemp, plmask) + if (ntp > 0) tp%capom(:) = pack(rtemp, tpmask) + + call netcdf_check( nf90_get_var(nc%id, nc%omega_varid, rtemp, start=[1, tslot], count=[idmax,1]), "swiftest_io_netcdf_read_frame_system nf90_getvar omega_varid" ) + rtemp = rtemp * DEG2RAD + if (.not.allocated(pl%omega)) allocate(pl%omega(npl)) + if (.not.allocated(tp%omega)) allocate(tp%omega(ntp)) + if (npl > 0) pl%omega(:) = pack(rtemp, plmask) + if (ntp > 0) tp%omega(:) = pack(rtemp, tpmask) + + call netcdf_check( nf90_get_var(nc%id, nc%capm_varid, rtemp, start=[1, tslot], count=[idmax,1]), "swiftest_io_netcdf_read_frame_system nf90_getvar capm_varid" ) + rtemp = rtemp * DEG2RAD + if (.not.allocated(pl%capm)) allocate(pl%capm(npl)) + if (.not.allocated(tp%capm)) allocate(tp%capm(ntp)) + if (npl > 0) pl%capm(:) = pack(rtemp, plmask) + if (ntp > 0) tp%capm(:) = pack(rtemp, tpmask) + + end if + + call netcdf_check( nf90_get_var(nc%id, nc%Gmass_varid, rtemp, start=[1, tslot], count=[idmax,1]), "swiftest_io_netcdf_read_frame_system nf90_getvar Gmass_varid" ) + cb%Gmass = rtemp(1) + cb%mass = cb%Gmass / param%GU + + ! Set initial central body mass for Helio bookkeeping + cb%GM0 = cb%Gmass + + + if (npl > 0) then + pl%Gmass(:) = pack(rtemp, plmask) + pl%mass(:) = pl%Gmass(:) / param%GU + + if (param%lrhill_present) then + call netcdf_check( nf90_get_var(nc%id, nc%rhill_varid, rtemp, start=[1, tslot], count=[idmax,1]), "swiftest_io_netcdf_read_frame_system nf90_getvar rhill_varid" ) + pl%rhill(:) = pack(rtemp, plmask) + end if + end if + + if (param%lclose) then + call netcdf_check( nf90_get_var(nc%id, nc%radius_varid, rtemp, start=[1, tslot], count=[idmax,1]), "swiftest_io_netcdf_read_frame_system nf90_getvar radius_varid" ) + cb%radius = rtemp(1) + + ! Set initial central body radius for SyMBA bookkeeping + cb%R0 = cb%radius + if (npl > 0) pl%radius(:) = pack(rtemp, plmask) + else + cb%radius = param%rmin + if (npl > 0) pl%radius(:) = 0.0_DP + end if + + if (param%lrotation) then + call netcdf_check( nf90_get_var(nc%id, nc%Ip_varid, vectemp, start=[1, 1, tslot], count=[NDIM,idmax,1]), "swiftest_io_netcdf_read_frame_system nf90_getvar Ip_varid" ) + cb%Ip(:) = vectemp(:,1) + do i = 1, NDIM + if (npl > 0) pl%Ip(i,:) = pack(vectemp(i,:), plmask(:)) + end do + + call netcdf_check( nf90_get_var(nc%id, nc%rot_varid, vectemp, start=[1, 1, tslot], count=[NDIM,idmax,1]), "swiftest_io_netcdf_read_frame_system nf90_getvar rot_varid" ) + cb%rot(:) = vectemp(:,1) + do i = 1, NDIM + if (npl > 0) pl%rot(i,:) = pack(vectemp(i,:), plmask(:)) + end do + + ! Set initial central body angular momentum for bookkeeping + cb%L0(:) = cb%Ip(3) * cb%GM0 * cb%R0**2 * cb%rot(:) + end if + + ! if (param%ltides) then + ! call netcdf_check( nf90_get_var(nc%id, nc%k2_varid, rtemp, start=[1, tslot]), "swiftest_io_netcdf_read_frame_system nf90_getvar k2_varid" ) + ! cb%k2 = rtemp(1) + ! if (npl > 0) pl%k2(:) = pack(rtemp, plmask) + + ! call netcdf_check( nf90_get_var(nc%id, nc%Q_varid, rtemp, start=[1, tslot]), "swiftest_io_netcdf_read_frame_system nf90_getvar Q_varid" ) + ! cb%Q = rtemp(1) + ! if (npl > 0) pl%Q(:) = pack(rtemp, plmask) + ! end if + + status = nf90_inq_varid(nc%id, nc%j2rp2_varname, nc%j2rp2_varid) + if (status == nf90_noerr) then + call netcdf_check( nf90_get_var(nc%id, nc%j2rp2_varid, cb%j2rp2, start=[tslot]), "swiftest_io_netcdf_read_frame_system nf90_getvar j2rp2_varid" ) + else + cb%j2rp2 = 0.0_DP + end if + + status = nf90_inq_varid(nc%id, nc%j4rp4_varname, nc%j4rp4_varid) + if (status == nf90_noerr) then + call netcdf_check( nf90_get_var(nc%id, nc%j4rp4_varid, cb%j4rp4, start=[tslot]), "swiftest_io_netcdf_read_frame_system nf90_getvar j4rp4_varid" ) + else + cb%j4rp4 = 0.0_DP + end if + + call self%read_particle_info(nc, param, plmask, tpmask) + + if (param%in_form == "EL") then + call pl%el2xv(cb) + call tp%el2xv(cb) + end if + ! if this is a GR-enabled run, check to see if we got the pseudovelocities in. Otherwise, we'll need to generate them. + if (param%lgr .and. .not.(nc%lpseudo_vel_exists)) then + call pl%set_mu(cb) + call tp%set_mu(cb) + call pl%v2pv(param) + call tp%v2pv(param) + end if + + end associate + end select + + call nc%close() + + ierr = 0 + return + + 667 continue + write(*,*) "Error reading system frame in io_netcdf_read_frame_system" + + end function swiftest_io_netcdf_read_frame_system + + + module subroutine swiftest_io_netcdf_read_hdr_system(self, nc, param) + !! author: David A. Minton + !! + !! Reads header information (variables that change with time, but not particle id). + !! This subroutine swiftest_significantly improves the output over the original binary file, allowing us to track energy, momentum, and other quantities that + !! previously were handled as separate output files. + implicit none + ! Arguments + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object + class(base_io_netcdf_parameters), intent(inout) :: nc !! Parameters used to for reading a NetCDF dataset to file + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + ! Internals + integer(I4B) :: tslot, status, idmax + real(DP), dimension(:), allocatable :: gmtemp + logical, dimension(:), allocatable :: plmask, tpmask, plmmask + + + tslot = param%ioutput + call netcdf_check( nf90_inquire_dimension(nc%id, nc%name_dimid, len=idmax), "swiftest_io_netcdf_read_hdr_system nf90_inquire_dimension name_dimid" ) + call netcdf_check( nf90_get_var(nc%id, nc%time_varid, self%t, start=[tslot]), "swiftest_io_netcdf_read_hdr_system nf90_getvar time_varid" ) + + allocate(gmtemp(idmax)) + allocate(tpmask(idmax)) + allocate(plmask(idmax)) + allocate(plmmask(idmax)) + + call netcdf_check( nf90_get_var(nc%id, nc%Gmass_varid, gmtemp, start=[1,1], count=[idmax,1]), "swiftest_io_netcdf_read_hdr_system nf90_getvar Gmass_varid" ) + + plmask(:) = gmtemp(:) == gmtemp(:) + tpmask(:) = .not. plmask(:) + plmask(1) = .false. ! This is the central body + plmmask(:) = plmask(:) + where(plmask(:)) + plmmask(:) = gmtemp(:) > param%GMTINY + endwhere + + status = nf90_inq_varid(nc%id, nc%npl_varname, nc%npl_varid) + if (status == nf90_noerr) then + call netcdf_check( nf90_get_var(nc%id, nc%npl_varid, self%pl%nbody, start=[tslot]), "swiftest_io_netcdf_read_hdr_system nf90_getvar npl_varid" ) + else + self%pl%nbody = count(plmask(:)) + end if + + status = nf90_inq_varid(nc%id, nc%ntp_varname, nc%ntp_varid) + if (status == nf90_noerr) then + call netcdf_check( nf90_get_var(nc%id, nc%ntp_varid, self%tp%nbody, start=[tslot]), "swiftest_io_netcdf_read_hdr_system nf90_getvar ntp_varid" ) + else + self%tp%nbody = count(tpmask(:)) + end if + + if (param%integrator == INT_SYMBA) then + status = nf90_inq_varid(nc%id, nc%nplm_varname, nc%nplm_varid) + if (status == nf90_noerr) then + call netcdf_check( nf90_get_var(nc%id, nc%nplm_varid, self%pl%nplm, start=[tslot]), "swiftest_io_netcdf_read_hdr_system nf90_getvar nplm_varid" ) + else + self%pl%nplm = count(plmmask(:)) + end if + end if + + if (param%lenergy) then + status = nf90_inq_varid(nc%id, nc%ke_orb_varname, nc%KE_orb_varid) + if (status == nf90_noerr) call netcdf_check( nf90_get_var(nc%id, nc%KE_orb_varid, self%ke_orbit, start=[tslot]), "swiftest_io_netcdf_read_hdr_system nf90_getvar KE_orb_varid" ) + status = nf90_inq_varid(nc%id, nc%ke_spin_varname, nc%KE_spin_varid) + if (status == nf90_noerr) call netcdf_check( nf90_get_var(nc%id, nc%KE_spin_varid, self%ke_spin, start=[tslot]), "swiftest_io_netcdf_read_hdr_system nf90_getvar KE_spin_varid" ) + status = nf90_inq_varid(nc%id, nc%pe_varname, nc%PE_varid) + if (status == nf90_noerr) call netcdf_check( nf90_get_var(nc%id, nc%PE_varid, self%pe, start=[tslot]), "swiftest_io_netcdf_read_hdr_system nf90_getvar PE_varid" ) + status = nf90_inq_varid(nc%id, nc%L_orb_varname, nc%L_orb_varid) + if (status == nf90_noerr) call netcdf_check( nf90_get_var(nc%id, nc%L_orb_varid, self%Lorbit(:), start=[1,tslot], count=[NDIM,1]), "swiftest_io_netcdf_read_hdr_system nf90_getvar L_orb_varid" ) + status = nf90_inq_varid(nc%id, nc%Lspin_varname, nc%Lspin_varid) + if (status == nf90_noerr) call netcdf_check( nf90_get_var(nc%id, nc%Lspin_varid, self%Lspin(:), start=[1,tslot], count=[NDIM,1]), "swiftest_io_netcdf_read_hdr_system nf90_getvar Lspin_varid" ) + status = nf90_inq_varid(nc%id, nc%L_escape_varname, nc%L_escape_varid) + if (status == nf90_noerr) call netcdf_check( nf90_get_var(nc%id, nc%L_escape_varid, self%Lescape(:), start=[1, tslot], count=[NDIM,1]), "swiftest_io_netcdf_read_hdr_system nf90_getvar L_escape_varid" ) + status = nf90_inq_varid(nc%id, nc%Ecollisions_varname, nc%Ecollisions_varid) + if (status == nf90_noerr) call netcdf_check( nf90_get_var(nc%id, nc%Ecollisions_varid, self%Ecollisions, start=[tslot]), "swiftest_io_netcdf_read_hdr_system nf90_getvar Ecollisions_varid" ) + status = nf90_inq_varid(nc%id, nc%Euntracked_varname, nc%Euntracked_varid) + if (status == nf90_noerr) call netcdf_check( nf90_get_var(nc%id, nc%Euntracked_varid, self%Euntracked, start=[tslot]), "swiftest_io_netcdf_read_hdr_system nf90_getvar Euntracked_varid" ) + status = nf90_inq_varid(nc%id, nc%GMescape_varname, nc%GMescape_varid) + if (status == nf90_noerr) call netcdf_check( nf90_get_var(nc%id, nc%GMescape_varid, self%GMescape, start=[tslot]), "swiftest_io_netcdf_read_hdr_system nf90_getvar GMescape_varid" ) + end if + + return + end subroutine swiftest_io_netcdf_read_hdr_system + + + module subroutine swiftest_io_netcdf_read_particle_info_system(self, nc, param, plmask, tpmask) + !! author: Carlisle A. Wishard, Dana Singh, and David A. Minton + !! + !! Reads particle information metadata from file + implicit none + ! Arguments + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object + class(base_io_netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular NetCDF dataset + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + logical, dimension(:), intent(in) :: plmask !! Logical array indicating which index values belong to massive bodies + logical, dimension(:), intent(in) :: tpmask !! Logical array indicating which index values belong to test particles + + ! Internals + integer(I4B) :: i, idmax, status + real(DP), dimension(:), allocatable :: rtemp + real(DP), dimension(:,:), allocatable :: vectemp + integer(I4B), dimension(:), allocatable :: itemp + character(len=NAMELEN), dimension(:), allocatable :: ctemp + integer(I4B), dimension(:), allocatable :: plind, tpind + + ! This string of spaces of length NAMELEN is used to clear out any old data left behind inside the string variables + idmax = size(plmask) + allocate(rtemp(idmax)) + allocate(vectemp(NDIM,idmax)) + allocate(itemp(idmax)) + allocate(ctemp(idmax)) + + associate(cb => self%cb, pl => self%pl, tp => self%tp, npl => self%pl%nbody, ntp => self%tp%nbody) + + if (npl > 0) then + pl%status(:) = ACTIVE + pl%lmask(:) = .true. + do i = 1, npl + call pl%info(i)%set_value(status="ACTIVE") + end do + allocate(plind(npl)) + plind(:) = pack([(i, i = 1, idmax)], plmask(:)) + end if + if (ntp > 0) then + tp%status(:) = ACTIVE + tp%lmask(:) = .true. + do i = 1, ntp + call tp%info(i)%set_value(status="ACTIVE") + end do + allocate(tpind(ntp)) + tpind(:) = pack([(i, i = 1, idmax)], tpmask(:)) + end if + + call netcdf_check( nf90_get_var(nc%id, nc%id_varid, itemp), "swiftest_io_netcdf_read_particle_info_system nf90_getvar id_varid" ) + cb%id = itemp(1) + pl%id(:) = pack(itemp, plmask) + tp%id(:) = pack(itemp, tpmask) + cb%id = 0 + pl%id(:) = pack([(i,i=0,idmax-1)],plmask) + tp%id(:) = pack([(i,i=0,idmax-1)],tpmask) + + call netcdf_check( nf90_get_var(nc%id, nc%name_varid, ctemp, count=[NAMELEN, idmax]), "swiftest_io_netcdf_read_particle_info_system nf90_getvar name_varid" ) + call cb%info%set_value(name=ctemp(1)) + do i = 1, npl + call pl%info(i)%set_value(name=ctemp(plind(i))) + end do + do i = 1, ntp + call tp%info(i)%set_value(name=ctemp(tpind(i))) + end do + + status = nf90_get_var(nc%id, nc%ptype_varid, ctemp, count=[NAMELEN, idmax]) + if (status /= nf90_noerr) then ! Set default particle types + call cb%info%set_value(particle_type=CB_TYPE_NAME) + + ! Handle semi-interacting bodies in SyMBA + select type(pl) + class is (symba_pl) + select type (param) + class is (swiftest_parameters) + do i = 1, npl + if (pl%Gmass(i) < param%GMTINY) then + call pl%info(i)%set_value(particle_type=PL_TINY_TYPE_NAME) + else + call pl%info(i)%set_value(particle_type=PL_TYPE_NAME) + end if + end do + end select + class default ! Non-SyMBA massive bodies + do i = 1, npl + call pl%info(i)%set_value(particle_type=PL_TYPE_NAME) + end do + end select + do i = 1, ntp + call tp%info(i)%set_value(particle_type=TP_TYPE_NAME) + end do + else ! Use particle types defined in input file + call cb%info%set_value(particle_type=ctemp(1)) + do i = 1, npl + call pl%info(i)%set_value(particle_type=ctemp(plind(i))) + end do + do i = 1, ntp + call tp%info(i)%set_value(particle_type=ctemp(tpind(i))) + end do + end if + + call cb%info%set_value(status="ACTIVE") + + if (param%lclose) then + + status = nf90_inq_varid(nc%id, nc%origin_type_varname, nc%origin_type_varid) + if (status == nf90_noerr) then + call netcdf_check( nf90_get_var(nc%id, nc%origin_type_varid, ctemp, count=[NAMELEN, idmax]), "swiftest_io_netcdf_read_particle_info_system nf90_getvar origin_type_varid" ) + else + ctemp = "Initial Conditions" + end if + + call cb%info%set_value(origin_type=ctemp(1)) + do i = 1, npl + call pl%info(i)%set_value(origin_type=ctemp(plind(i))) + end do + do i = 1, ntp + call tp%info(i)%set_value(origin_type=ctemp(tpind(i))) + end do + + status = nf90_inq_varid(nc%id, nc%origin_time_varname, nc%origin_time_varid) + if (status == nf90_noerr) then + call netcdf_check( nf90_get_var(nc%id, nc%origin_time_varid, rtemp), "swiftest_io_netcdf_read_particle_info_system nf90_getvar origin_time_varid" ) + else + rtemp = param%t0 + end if + + call cb%info%set_value(origin_time=rtemp(1)) + do i = 1, npl + call pl%info(i)%set_value(origin_time=rtemp(plind(i))) + end do + do i = 1, ntp + call tp%info(i)%set_value(origin_time=rtemp(tpind(i))) + end do + + status = nf90_inq_varid(nc%id, nc%origin_rh_varname, nc%origin_rh_varid) + if (status == nf90_noerr) then + call netcdf_check( nf90_get_var(nc%id, nc%origin_rh_varid, vectemp(:,:)), "swiftest_io_netcdf_read_particle_info_system nf90_getvar origin_rh_varid" ) + else if ((param%out_form == "XV") .or. (param%out_form == "XVEL")) then + call netcdf_check( nf90_get_var(nc%id, nc%rh_varid, vectemp(:,:)), "swiftest_io_netcdf_read_particle_info_system nf90_getvar rh_varid" ) + else + vectemp(:,:) = 0._DP + end if + + do i = 1, npl + call pl%info(i)%set_value(origin_rh=vectemp(:,plind(i))) + end do + do i = 1, ntp + call tp%info(i)%set_value(origin_rh=vectemp(:,tpind(i))) + end do + + status = nf90_inq_varid(nc%id, nc%origin_vh_varname, nc%origin_vh_varid) + if (status == nf90_noerr) then + call netcdf_check( nf90_get_var(nc%id, nc%origin_vh_varid, vectemp(:,:)), "swiftest_io_netcdf_read_particle_info_system nf90_getvar origin_vh_varid" ) + else if ((param%out_form == "XV") .or. (param%out_form == "XVEL")) then + call netcdf_check( nf90_get_var(nc%id, nc%vh_varid, vectemp(:,:)), "swiftest_io_netcdf_read_particle_info_system nf90_getvar vh_varid" ) + else + vectemp(:,:) = 0._DP + end if + + do i = 1, npl + call pl%info(i)%set_value(origin_vh=vectemp(:,plind(i))) + end do + do i = 1, ntp + call tp%info(i)%set_value(origin_vh=vectemp(:,tpind(i))) + end do + + status = nf90_inq_varid(nc%id, nc%collision_id_varname, nc%collision_id_varid) + if (status == nf90_noerr) then + call netcdf_check( nf90_get_var(nc%id, nc%collision_id_varid, itemp), "swiftest_io_netcdf_read_particle_info_system nf90_getvar collision_id_varid" ) + else + itemp = 0 + end if + + do i = 1, npl + call pl%info(i)%set_value(collision_id=itemp(plind(i))) + end do + do i = 1, ntp + call tp%info(i)%set_value(collision_id=itemp(tpind(i))) + end do + + status = nf90_inq_varid(nc%id, nc%discard_time_varname, nc%discard_time_varid) + if (status == nf90_noerr) then + call netcdf_check( nf90_get_var(nc%id, nc%discard_time_varid, rtemp), "swiftest_io_netcdf_read_particle_info_system nf90_getvar discard_time_varid" ) + else + select case (param%out_type) + case("swiftest_io_netcdf_FLOAT") + rtemp(:) = huge(0.0_SP) + case("swiftest_io_netcdf_DOUBLE") + rtemp(:) = huge(0.0_DP) + end select + end if + + call cb%info%set_value(discard_time=rtemp(1)) + do i = 1, npl + call pl%info(i)%set_value(discard_time=rtemp(plind(i))) + end do + do i = 1, ntp + call tp%info(i)%set_value(discard_time=rtemp(tpind(i))) + end do + + status = nf90_inq_varid(nc%id, nc%discard_rh_varname, nc%discard_rh_varid) + if (status == nf90_noerr) then + call netcdf_check( nf90_get_var(nc%id, nc%discard_rh_varid, vectemp(:,:)), "swiftest_io_netcdf_read_particle_info_system nf90_getvar discard_rh_varid" ) + else + vectemp(:,:) = 0.0_DP + end if + + do i = 1, npl + call pl%info(i)%set_value(discard_rh=vectemp(:,plind(i))) + end do + do i = 1, ntp + call tp%info(i)%set_value(discard_rh=vectemp(:,tpind(i))) + end do + + status = nf90_inq_varid(nc%id, nc%discard_vh_varname, nc%discard_vh_varid) + if (status == nf90_noerr) then + call netcdf_check( nf90_get_var(nc%id, nc%discard_vh_varid, vectemp(:,:)), "swiftest_io_netcdf_read_particle_info_system nf90_getvar discard_vh_varid" ) + else + vectemp(:,:) = 0.0_DP + end if + + do i = 1, npl + call pl%info(i)%set_value(discard_vh=vectemp(:,plind(i))) + end do + do i = 1, ntp + call tp%info(i)%set_value(discard_vh=vectemp(:,tpind(i))) + end do + end if + + end associate + + return + end subroutine swiftest_io_netcdf_read_particle_info_system + + + module subroutine swiftest_io_netcdf_write_frame_body(self, nc, param) + !! author: Carlisle A. Wishard, Dana Singh, and David A. Minton + !! + !! Write a frame of output of either test particle or massive body data to the binary output file + !! Note: If outputting to orbital elements, but sure that the conversion is done prior to calling this method + implicit none + ! Arguments + class(swiftest_body), intent(in) :: self !! Swiftest base object + class(base_io_netcdf_parameters), intent(inout) :: nc !! Parameters used to for writing a NetCDF dataset to file + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + ! Internals + integer(I4B) :: i, j, tslot, idslot, old_mode + integer(I4B), dimension(:), allocatable :: ind + real(DP), dimension(NDIM) :: vh !! Temporary variable to store heliocentric velocity values when converting from pseudovelocity in GR-enabled runs + real(DP) :: a, e, inc, omega, capom, capm, varpi, lam, f, cape, capf + + tslot = param%ioutput + + call self%write_info(nc, param) + + call netcdf_check( nf90_set_fill(nc%id, nf90_nofill, old_mode), "swiftest_io_netcdf_write_frame_body nf90_set_fill" ) + select type(self) + class is (swiftest_body) + associate(n => self%nbody) + if (n == 0) return + + call util_sort(self%id(1:n), ind) + + do i = 1, n + j = ind(i) + idslot = self%id(j) + 1 + + !! Convert from pseudovelocity to heliocentric without replacing the current value of pseudovelocity + if (param%lgr) call swiftest_gr_pseudovel2vel(param, self%mu(j), self%rh(:, j), self%vh(:, j), vh(:)) + + if ((param%out_form == "XV") .or. (param%out_form == "XVEL")) then + call netcdf_check( nf90_put_var(nc%id, nc%rh_varid, self%rh(:, j), start=[1,idslot, tslot], count=[NDIM,1,1]), "swiftest_io_netcdf_write_frame_body nf90_put_var rh_varid" ) + if (param%lgr) then !! Convert from pseudovelocity to heliocentric without replacing the current value of pseudovelocity + call netcdf_check( nf90_put_var(nc%id, nc%vh_varid, vh(:), start=[1,idslot, tslot], count=[NDIM,1,1]), "swiftest_io_netcdf_write_frame_body nf90_put_var vh_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%gr_pseudo_vh_varid, self%vh(:, j), start=[1,idslot, tslot],count=[NDIM,1,1]), "swiftest_io_netcdf_write_frame_body nf90_put_var gr_pseudo_vhx_varid" ) + + else + call netcdf_check( nf90_put_var(nc%id, nc%vh_varid, self%vh(:, j), start=[1,idslot, tslot], count=[NDIM,1,1]), "swiftest_io_netcdf_write_frame_body nf90_put_var vh_varid" ) + end if + end if + + if ((param%out_form == "EL") .or. (param%out_form == "XVEL")) then + if (param%lgr) then !! For GR-enabled runs, use the true value of velocity computed above + call swiftest_orbel_xv2el(self%mu(j), self%rh(1,j), self%rh(2,j), self%rh(3,j), & + vh(1), vh(2), vh(3), & + a, e, inc, capom, omega, capm, varpi, lam, f, cape, capf) + else !! For non-GR runs just convert from the velocity we have + call swiftest_orbel_xv2el(self%mu(j), self%rh(1,j), self%rh(2,j), self%rh(3,j), & + self%vh(1,j), self%vh(2,j), self%vh(3,j), & + a, e, inc, capom, omega, capm, varpi, lam, f, cape, capf) + end if + call netcdf_check( nf90_put_var(nc%id, nc%a_varid, a, start=[idslot, tslot]), "swiftest_io_netcdf_write_frame_body nf90_put_var body a_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%e_varid, e, start=[idslot, tslot]), "swiftest_io_netcdf_write_frame_body nf90_put_var body e_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%inc_varid, inc * RAD2DEG, start=[idslot, tslot]), "swiftest_io_netcdf_write_frame_body nf90_put_var body inc_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%capom_varid, capom * RAD2DEG, start=[idslot, tslot]), "swiftest_io_netcdf_write_frame_body nf90_put_var body capom_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%omega_varid, omega * RAD2DEG, start=[idslot, tslot]), "swiftest_io_netcdf_write_frame_body nf90_put_var body omega_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%capm_varid, capm * RAD2DEG, start=[idslot, tslot]), "swiftest_io_netcdf_write_frame_body nf90_put_var body capm_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%varpi_varid, varpi * RAD2DEG, start=[idslot, tslot]), "swiftest_io_netcdf_write_frame_body nf90_put_var body varpi_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%lam_varid, lam * RAD2DEG, start=[idslot, tslot]), "swiftest_io_netcdf_write_frame_body nf90_put_var body lam_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%f_varid, f * RAD2DEG, start=[idslot, tslot]), "swiftest_io_netcdf_write_frame_body nf90_put_var body f_varid" ) + if (e < 1.0_DP) then + call netcdf_check( nf90_put_var(nc%id, nc%cape_varid, cape * RAD2DEG, start=[idslot, tslot]), "swiftest_io_netcdf_write_frame_body nf90_put_var body cape_varid" ) + else if (e > 1.0_DP) then + call netcdf_check( nf90_put_var(nc%id, nc%cape_varid, capf * RAD2DEG, start=[idslot, tslot]), "swiftest_io_netcdf_write_frame_body nf90_put_var body (capf) cape_varid" ) + end if + end if + + select type(self) + class is (swiftest_pl) ! Additional output if the passed polymorphic object is a massive body + call netcdf_check( nf90_put_var(nc%id, nc%Gmass_varid, self%Gmass(j), start=[idslot, tslot]), "swiftest_io_netcdf_write_frame_body nf90_put_var body Gmass_varid" ) + if (param%lrhill_present) then + call netcdf_check( nf90_put_var(nc%id, nc%rhill_varid, self%rhill(j), start=[idslot, tslot]), "swiftest_io_netcdf_write_frame_body nf90_put_var body rhill_varid" ) + end if + if (param%lclose) call netcdf_check( nf90_put_var(nc%id, nc%radius_varid, self%radius(j), start=[idslot, tslot]), "swiftest_io_netcdf_write_frame_body nf90_put_var body radius_varid" ) + if (param%lrotation) then + call netcdf_check( nf90_put_var(nc%id, nc%Ip_varid, self%Ip(:, j), start=[1,idslot, tslot], count=[NDIM,1,1]), "swiftest_io_netcdf_write_frame_body nf90_put_var body Ip_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%rot_varid, self%rot(:, j), start=[1,idslot, tslot], count=[NDIM,1,1]), "swiftest_io_netcdf_write_frame_body nf90_put_var body rotx_varid" ) + end if + ! if (param%ltides) then + ! call netcdf_check( nf90_put_var(nc%id, nc%k2_varid, self%k2(j), start=[idslot, tslot]), "swiftest_io_netcdf_write_frame_body nf90_put_var body k2_varid" ) + ! call netcdf_check( nf90_put_var(nc%id, nc%Q_varid, self%Q(j), start=[idslot, tslot]), "swiftest_io_netcdf_write_frame_body nf90_put_var body Q_varid" ) + ! end if + + end select + end do + end associate + class is (swiftest_cb) + idslot = self%id + 1 + call netcdf_check( nf90_put_var(nc%id, nc%id_varid, self%id, start=[idslot]), "swiftest_io_netcdf_write_frame_body nf90_put_var cb id_varid" ) + + call netcdf_check( nf90_put_var(nc%id, nc%Gmass_varid, self%Gmass, start=[idslot, tslot]), "swiftest_io_netcdf_write_frame_body nf90_put_var cb Gmass_varid" ) + if (param%lclose) call netcdf_check( nf90_put_var(nc%id, nc%radius_varid, self%radius, start=[idslot, tslot]), "swiftest_io_netcdf_write_frame_body nf90_put_var cb radius_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%j2rp2_varid, self%j2rp2, start=[tslot]), "swiftest_io_netcdf_write_frame_body nf90_put_var cb j2rp2_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%j4rp4_varid, self%j4rp4, start=[tslot]), "swiftest_io_netcdf_write_frame_body nf90_put_var cb j4rp4_varid" ) + if (param%lrotation) then + call netcdf_check( nf90_put_var(nc%id, nc%Ip_varid, self%Ip(:), start=[1, idslot, tslot], count=[NDIM,1,1]), "swiftest_io_netcdf_write_frame_body nf90_put_var cb Ip_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%rot_varid, self%rot(:), start=[1, idslot, tslot], count=[NDIM,1,1]), "swiftest_io_netcdf_write_frame_body nf90_put_var cb rot_varid" ) + end if + ! if (param%ltides) then + ! call netcdf_check( nf90_put_var(nc%id, nc%k2_varid, self%k2, start=[idslot, tslot]), "swiftest_io_netcdf_write_frame_body nf90_put_var cb k2_varid" ) + ! call netcdf_check( nf90_put_var(nc%id, nc%Q_varid, self%Q, start=[idslot, tslot]), "swiftest_io_netcdf_write_frame_body nf90_put_var cb Q_varid" ) + ! end if + + end select + call netcdf_check( nf90_set_fill(nc%id, old_mode, old_mode), "swiftest_io_netcdf_write_frame_body nf90_set_fill old_mode" ) + + return + end subroutine swiftest_io_netcdf_write_frame_body + + + module subroutine swiftest_io_netcdf_write_frame_system(self, nc, param) + !! author: The Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott + !! + !! Write a frame (header plus records for each massive body and active test particle) to a output binary file + implicit none + ! Arguments + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest system object + class(base_io_netcdf_parameters), intent(inout) :: nc !! Parameters used to for writing a NetCDF dataset to file + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + + call self%write_hdr(nc, param) + call self%cb%write_frame(nc, param) + call self%pl%write_frame(nc, param) + call self%tp%write_frame(nc, param) + + return + end subroutine swiftest_io_netcdf_write_frame_system + + + + module subroutine swiftest_io_netcdf_write_hdr_system(self, nc, param) + !! author: David A. Minton + !! + !! Writes header information (variables that change with time, but not particle id). + !! This subroutine swiftest_significantly improves the output over the original binary file, allowing us to track energy, momentum, and other quantities that + !! previously were handled as separate output files. + implicit none + ! Arguments + class(swiftest_nbody_system), intent(in) :: self !! Swiftest nbody system object + class(base_io_netcdf_parameters), intent(inout) :: nc !! Parameters used to for writing a NetCDF dataset to file + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + ! Internals + integer(I4B) :: tslot + + tslot = param%ioutput + + call netcdf_check( nf90_put_var(nc%id, nc%time_varid, self%t, start=[tslot]), "swiftest_io_netcdf_write_hdr_system nf90_put_var time_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%npl_varid, self%pl%nbody, start=[tslot]), "swiftest_io_netcdf_write_hdr_system nf90_put_var npl_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%ntp_varid, self%tp%nbody, start=[tslot]), "swiftest_io_netcdf_write_hdr_system nf90_put_var ntp_varid" ) + select type(pl => self%pl) + class is (symba_pl) + call netcdf_check( nf90_put_var(nc%id, nc%nplm_varid, pl%nplm, start=[tslot]), "swiftest_io_netcdf_write_hdr_system nf90_put_var nplm_varid" ) + end select + + if (param%lenergy) then + call netcdf_check( nf90_put_var(nc%id, nc%KE_orb_varid, self%ke_orbit, start=[tslot]), "swiftest_io_netcdf_write_hdr_system nf90_put_var KE_orb_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%KE_spin_varid, self%ke_spin, start=[tslot]), "swiftest_io_netcdf_write_hdr_system nf90_put_var KE_spin_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%PE_varid, self%pe, start=[tslot]), "swiftest_io_netcdf_write_hdr_system nf90_put_var PE_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%L_orb_varid, self%Lorbit(:), start=[1,tslot], count=[NDIM,1]), "swiftest_io_netcdf_write_hdr_system nf90_put_var L_orb_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%Lspin_varid, self%Lspin(:), start=[1,tslot], count=[NDIM,1]), "swiftest_io_netcdf_write_hdr_system nf90_put_var Lspin_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%L_escape_varid, self%Lescape(:), start=[1,tslot], count=[NDIM,1]), "swiftest_io_netcdf_write_hdr_system nf90_put_var L_escape_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%Ecollisions_varid, self%Ecollisions, start=[tslot]), "swiftest_io_netcdf_write_hdr_system nf90_put_var Ecollisions_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%Euntracked_varid, self%Euntracked, start=[tslot]), "swiftest_io_netcdf_write_hdr_system nf90_put_var Euntracked_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%GMescape_varid, self%GMescape, start=[tslot]), "swiftest_io_netcdf_write_hdr_system nf90_put_var GMescape_varid" ) + end if + + return + end subroutine swiftest_io_netcdf_write_hdr_system + + + module subroutine swiftest_io_netcdf_write_info_body(self, nc, param) + !! author: Carlisle A. Wishard, Dana Singh, and David A. Minton + !! + !! Write all current particle to file + implicit none + ! Arguments + class(swiftest_body), intent(in) :: self !! Swiftest particle object + class(base_io_netcdf_parameters), intent(inout) :: nc !! Parameters used to identify a particular NetCDF dataset + class(base_parameters), intent(inout) :: param !! Current run configuration parameters + ! Internals + integer(I4B) :: i, j, idslot, old_mode + integer(I4B), dimension(:), allocatable :: ind + character(len=:), allocatable :: charstring + + ! This string of spaces of length NAMELEN is used to clear out any old data left behind inside the string variables + call netcdf_check( nf90_set_fill(nc%id, nf90_nofill, old_mode), "swiftest_io_netcdf_write_info_body nf90_set_fill nf90_nofill" ) + + select type(self) + class is (swiftest_body) + associate(n => self%nbody) + if (n == 0) return + call util_sort(self%id(1:n), ind) + + do i = 1, n + j = ind(i) + idslot = self%id(j) + 1 + call netcdf_check( nf90_put_var(nc%id, nc%id_varid, self%id(j), start=[idslot]), "swiftest_io_netcdf_write_info_body nf90_put_var id_varid" ) + + charstring = trim(adjustl(self%info(j)%name)) + call netcdf_check( nf90_put_var(nc%id, nc%name_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "swiftest_io_netcdf_write_info_body nf90_put_var name_varid" ) + + charstring = trim(adjustl(self%info(j)%particle_type)) + call netcdf_check( nf90_put_var(nc%id, nc%ptype_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "swiftest_io_netcdf_write_info_body nf90_put_var particle_type_varid" ) + + if (param%lclose) then + charstring = trim(adjustl(self%info(j)%origin_type)) + call netcdf_check( nf90_put_var(nc%id, nc%origin_type_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "swiftest_io_netcdf_write_info_body nf90_put_var origin_type_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%origin_time_varid, self%info(j)%origin_time, start=[idslot]), "swiftest_io_netcdf_write_info_body nf90_put_var origin_time_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%origin_rh_varid, self%info(j)%origin_rh(:), start=[1,idslot], count=[NDIM,1]), "swiftest_io_netcdf_write_info_body nf90_put_var origin_rh_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%origin_vh_varid, self%info(j)%origin_vh(:), start=[1,idslot], count=[NDIM,1]), "swiftest_io_netcdf_write_info_body nf90_put_var origin_vh_varid" ) + + call netcdf_check( nf90_put_var(nc%id, nc%collision_id_varid, self%info(j)%collision_id, start=[idslot]), "swiftest_io_netcdf_write_info_body nf90_put_var collision_id_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%discard_time_varid, self%info(j)%discard_time, start=[idslot]), "swiftest_io_netcdf_write_info_body nf90_put_var discard_time_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%discard_rh_varid, self%info(j)%discard_rh(:), start=[1,idslot], count=[NDIM,1]), "swiftest_io_netcdf_write_info_body nf90_put_var discard_rh_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%discard_vh_varid, self%info(j)%discard_vh(:), start=[1,idslot], count=[NDIM,1]), "swiftest_io_netcdf_write_info_body nf90_put_var discard_vh_varid" ) + end if + + end do + end associate + + class is (swiftest_cb) + idslot = self%id + 1 + call netcdf_check( nf90_put_var(nc%id, nc%id_varid, self%id, start=[idslot]), "swiftest_io_netcdf_write_info_body nf90_put_var cb id_varid" ) + + charstring = trim(adjustl(self%info%name)) + call netcdf_check( nf90_put_var(nc%id, nc%name_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "swiftest_io_netcdf_write_info_body nf90_put_var cb name_varid" ) + + charstring = trim(adjustl(self%info%particle_type)) + call netcdf_check( nf90_put_var(nc%id, nc%ptype_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "swiftest_io_netcdf_write_info_body nf90_put_var cb ptype_varid" ) + + if (param%lclose) then + charstring = trim(adjustl(self%info%origin_type)) + call netcdf_check( nf90_put_var(nc%id, nc%origin_type_varid, charstring, start=[1, idslot], count=[len(charstring), 1]), "swiftest_io_netcdf_write_info_body nf90_put_var cb origin_type_varid" ) + + call netcdf_check( nf90_put_var(nc%id, nc%origin_time_varid, self%info%origin_time, start=[idslot]), "swiftest_io_netcdf_write_info_body nf90_put_var cb origin_time_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%origin_rh_varid, self%info%origin_rh(:), start=[1, idslot], count=[NDIM,1]), "swiftest_io_netcdf_write_info_body nf90_put_var cb origin_rh_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%origin_vh_varid, self%info%origin_vh(:), start=[1, idslot], count=[NDIM,1]), "swiftest_io_netcdf_write_info_body nf90_put_var cb origin_vh_varid" ) + + call netcdf_check( nf90_put_var(nc%id, nc%collision_id_varid, self%info%collision_id, start=[idslot]), "swiftest_io_netcdf_write_info_body nf90_put_var cb collision_id_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%discard_time_varid, self%info%discard_time, start=[idslot]), "swiftest_io_netcdf_write_info_body nf90_put_var cb discard_time_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%discard_rh_varid, self%info%discard_rh(:), start=[1, idslot], count=[NDIM,1]), "swiftest_io_netcdf_write_info_body nf90_put_var cb discard_rh_varid" ) + call netcdf_check( nf90_put_var(nc%id, nc%discard_vh_varid, self%info%discard_vh(:), start=[1, idslot], count=[NDIM,1]), "swiftest_io_netcdf_write_info_body nf90_put_var cb discard_vh_varid" ) + end if + + end select + + call netcdf_check( nf90_set_fill(nc%id, old_mode, old_mode) ) + return + end subroutine swiftest_io_netcdf_write_info_body + +end submodule s_io_netcdf diff --git a/src/kick/kick.f90 b/src/swiftest_procedures/swiftest_kick.f90 similarity index 92% rename from src/kick/kick.f90 rename to src/swiftest_procedures/swiftest_kick.f90 index 8f1ae7e08..b1c9fe20a 100644 --- a/src/kick/kick.f90 +++ b/src/swiftest_procedures/swiftest_kick.f90 @@ -7,11 +7,9 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(swiftest_classes) s_kick - use swiftest +submodule(swiftets) s_kick contains - - module subroutine kick_getacch_int_pl(self, param) + module subroutine swiftest_kick_getacch_int_pl(self, param) !! author: David A. Minton !! !! Compute direct cross (third) term heliocentric accelerations of massive bodies @@ -34,7 +32,7 @@ module subroutine kick_getacch_int_pl(self, param) call itimer%time_this_loop(param, self%nplpl, self) lfirst = .false. else - if (itimer%check(param, self%nplpl)) call itimer%time_this_loop(param, self%nplpl, self) + if (itimer%io_netcdf_check(param, self%nplpl)) call itimer%time_this_loop(param, self%nplpl, self) end if else param%lflatten_interactions = .false. @@ -60,10 +58,10 @@ module subroutine kick_getacch_int_pl(self, param) end if return - end subroutine kick_getacch_int_pl + end subroutine swiftest_kick_getacch_int_pl - module subroutine kick_getacch_int_tp(self, param, GMpl, rhp, npl) + module subroutine swiftest_kick_getacch_int_tp(self, param, GMpl, rhp, npl) !! author: David A. Minton !! !! Compute direct cross (third) term heliocentric accelerations of test particles by massive bodies @@ -83,10 +81,10 @@ module subroutine kick_getacch_int_tp(self, param, GMpl, rhp, npl) call kick_getacch_int_all_tp(self%nbody, npl, self%rh, rhp, GMpl, self%lmask, self%ah) return - end subroutine kick_getacch_int_tp + end subroutine swiftest_kick_getacch_int_tp - module subroutine kick_getacch_int_all_flat_pl(npl, nplpl, k_plpl, x, Gmass, radius, acc) + module subroutine swiftest_kick_getacch_int_all_flat_pl(npl, nplpl, k_plpl, x, Gmass, radius, acc) !! author: David A. Minton !! !! Compute direct cross (third) term heliocentric accelerations for massive bodies, with parallelization. @@ -152,10 +150,10 @@ module subroutine kick_getacch_int_all_flat_pl(npl, nplpl, k_plpl, x, Gmass, rad acc(:,:) = acc(:,:) + ahi(:,:) + ahj(:,:) return - end subroutine kick_getacch_int_all_flat_pl + end subroutine swiftest_kick_getacch_int_all_flat_pl - module subroutine kick_getacch_int_all_triangular_pl(npl, nplm, x, Gmass, radius, acc) + module subroutine swiftest_kick_getacch_int_all_triangular_pl(npl, nplm, x, Gmass, radius, acc) !! author: David A. Minton !! !! Compute direct cross (third) term heliocentric accelerations for massive bodies, with parallelization. @@ -221,10 +219,10 @@ module subroutine kick_getacch_int_all_triangular_pl(npl, nplm, x, Gmass, radius end do return - end subroutine kick_getacch_int_all_triangular_pl + end subroutine swiftest_kick_getacch_int_all_triangular_pl - module subroutine kick_getacch_int_all_tp(ntp, npl, xtp, xpl, GMpl, lmask, acc) + module subroutine swiftest_kick_getacch_int_all_tp(ntp, npl, xtp, xpl, GMpl, lmask, acc) !! author: David A. Minton !! !! Compute direct cross (third) term heliocentric accelerations of test particles by massive bodies with parallelisim @@ -261,10 +259,10 @@ module subroutine kick_getacch_int_all_tp(ntp, npl, xtp, xpl, GMpl, lmask, acc) !$omp end parallel do return - end subroutine kick_getacch_int_all_tp + end subroutine swiftest_kick_getacch_int_all_tp - pure module subroutine kick_getacch_int_one_pl(rji2, xr, yr, zr, Gmi, Gmj, axi, ayi, azi, axj, ayj, azj) + pure module subroutine swiftest_kick_getacch_int_one_pl(rji2, xr, yr, zr, Gmi, Gmj, axi, ayi, azi, axj, ayj, azj) !! author: David A. Minton !! !! Compute direct cross (third) term heliocentric accelerations for a single pair of massive bodies @@ -292,10 +290,10 @@ pure module subroutine kick_getacch_int_one_pl(rji2, xr, yr, zr, Gmi, Gmj, axi, azj = azj - faci * zr return - end subroutine kick_getacch_int_one_pl + end subroutine swiftest_kick_getacch_int_one_pl - pure module subroutine kick_getacch_int_one_tp(rji2, xr, yr, zr, GMpl, ax, ay, az) + pure module subroutine swiftest_kick_getacch_int_one_tp(rji2, xr, yr, zr, GMpl, ax, ay, az) !! author: David A. Minton !! !! Compute direct cross (third) term heliocentric accelerations of a single test particle massive body pair. @@ -316,6 +314,6 @@ pure module subroutine kick_getacch_int_one_tp(rji2, xr, yr, zr, GMpl, ax, ay, a az = az - fac * zr return - end subroutine kick_getacch_int_one_tp + end subroutine swiftest_kick_getacch_int_one_tp end submodule s_kick diff --git a/src/obl/obl.f90 b/src/swiftest_procedures/swiftest_obl.f90 similarity index 94% rename from src/obl/obl.f90 rename to src/swiftest_procedures/swiftest_obl.f90 index be964c3e5..3d3109d8c 100644 --- a/src/obl/obl.f90 +++ b/src/swiftest_procedures/swiftest_obl.f90 @@ -7,10 +7,9 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule (swiftest_classes) s_obl - use swiftest +submodule (swiftest) s_obl contains - module subroutine obl_acc_body(self, system) + module subroutine swiftest_obl_acc_body(self, system) !! author: David A. Minton !! !! Compute the barycentric accelerations of bodies due to the oblateness of the central body @@ -46,10 +45,10 @@ module subroutine obl_acc_body(self, system) end associate return - end subroutine obl_acc_body + end subroutine swiftest_obl_acc_body - module subroutine obl_acc_pl(self, system) + module subroutine swiftest_obl_acc_pl(self, system) !! author: David A. Minton !! !! Compute the barycentric accelerations of massive bodies due to the oblateness of the central body @@ -79,10 +78,10 @@ module subroutine obl_acc_pl(self, system) return - end subroutine obl_acc_pl + end subroutine swiftest_obl_acc_pl - module subroutine obl_acc_tp(self, system) + module subroutine swiftest_obl_acc_tp(self, system) !! author: David A. Minton !! !! Compute the barycentric accelerations of massive bodies due to the oblateness of the central body @@ -114,10 +113,10 @@ module subroutine obl_acc_tp(self, system) end associate return - end subroutine obl_acc_tp + end subroutine swiftest_obl_acc_tp - module subroutine obl_pot_system(self) + module subroutine swiftest_obl_pot_system(self) !! author: David A. Minton !! !! Compute the contribution to the total gravitational potential due solely to the oblateness of the central body @@ -143,7 +142,7 @@ module subroutine obl_pot_system(self) end associate return - end subroutine obl_pot_system + end subroutine swiftest_obl_pot_system elemental function obl_pot_one(GMcb, GMpl, j2rp2, j4rp4, zh, irh) result(oblpot) diff --git a/src/orbel/orbel.f90 b/src/swiftest_procedures/swiftest_orbel.f90 similarity index 87% rename from src/orbel/orbel.f90 rename to src/swiftest_procedures/swiftest_orbel.f90 index 0a4416160..c731c23a4 100644 --- a/src/orbel/orbel.f90 +++ b/src/swiftest_procedures/swiftest_orbel.f90 @@ -7,11 +7,10 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule (swiftest_classes) s_orbel - use swiftest +submodule (swiftest) s_orbel contains - module subroutine orbel_el2xv_vec(self, cb) + module subroutine swiftest_orbel_el2xv_vec(self, cb) !! author: David A. Minton !! !! A wrapper method that converts all of the orbital element vectors into cartesian position and velocity vectors for a Swiftest body object. @@ -27,14 +26,14 @@ module subroutine orbel_el2xv_vec(self, cb) call self%set_mu(cb) do concurrent (i = 1:self%nbody) - call orbel_el2xv(self%mu(i), self%a(i), self%e(i), self%inc(i), self%capom(i), & + call swiftest_orbel_el2xv(self%mu(i), self%a(i), self%e(i), self%inc(i), self%capom(i), & self%omega(i), self%capm(i), self%rh(:, i), self%vh(:, i)) end do return - end subroutine orbel_el2xv_vec + end subroutine swiftest_orbel_el2xv_vec - pure subroutine orbel_el2xv(mu, a, ie, inc, capom, omega, capm, x, v) + pure subroutine swiftest_orbel_el2xv(mu, a, ie, inc, capom, omega, capm, x, v) !! author: David A. Minton !! !! Compute osculating orbital elements from relative C)rtesian position and velocity @@ -63,7 +62,7 @@ pure subroutine orbel_el2xv(mu, a, ie, inc, capom, omega, capm, x, v) if(ie < 0.0_DP) then - !write(*,*) ' ERROR in orbel_el2xv: e<0, setting e=0!!1' + !write(*,*) ' ERROR in swiftest_orbel_el2xv: e<0, setting e=0!!1' e = 0.0_DP iorbit_type = ELLIPSE else @@ -78,9 +77,9 @@ pure subroutine orbel_el2xv(mu, a, ie, inc, capom, omega, capm, x, v) end if endif - call orbel_scget(omega,sip,cip) - call orbel_scget(capom,so,co) - call orbel_scget(inc,si,ci) + call swiftest_orbel_scget(omega,sip,cip) + call swiftest_orbel_scget(capom,so,co) + call swiftest_orbel_scget(inc,si,ci) d11 = cip * co - sip * so * ci d12 = cip * so + sip * co * ci d13 = sip * si @@ -92,8 +91,8 @@ pure subroutine orbel_el2xv(mu, a, ie, inc, capom, omega, capm, x, v) ! Get the other quantities depending on orbit type ! if (iorbit_type == ELLIPSE) then - cape = orbel_ehybrid(e,capm) - call orbel_scget(cape,scap,ccap) + cape = swiftest_orbel_ehybrid(e,capm) + call swiftest_orbel_scget(cape,scap,ccap) sqe = sqrt(1._DP - e**2) sqgma = sqrt(mu* a) xfac1 = a * (ccap - e) @@ -104,8 +103,8 @@ pure subroutine orbel_el2xv(mu, a, ie, inc, capom, omega, capm, x, v) endif !-- if (iorbit_type == HYPERBOLA) then - capf = orbel_fhybrid(e,capm) - call orbel_schget(capf,shcap,chcap) + capf = swiftest_orbel_fhybrid(e,capm) + call swiftest_orbel_schget(capf,shcap,chcap) sqe = sqrt(e**2 - 1._DP ) sqgma = sqrt(mu * a) xfac1 = a * (e - chcap) @@ -116,7 +115,7 @@ pure subroutine orbel_el2xv(mu, a, ie, inc, capom, omega, capm, x, v) endif !-- if (iorbit_type == PARABOLA) then - zpara = orbel_zget(capm) + zpara = swiftest_orbel_zget(capm) sqgma = sqrt(2 * mu * a) xfac1 = a * (1._DP - zpara * zpara) xfac2 = 2 * a * zpara @@ -133,10 +132,10 @@ pure subroutine orbel_el2xv(mu, a, ie, inc, capom, omega, capm, x, v) v(3) = d13 * vfac1 + d23 * vfac2 return - end subroutine orbel_el2xv + end subroutine swiftest_orbel_el2xv - pure module subroutine orbel_scget(angle, sx, cx) + pure module subroutine swiftest_orbel_scget(angle, sx, cx) !! author: David A. Minton !! !! Efficiently compute the sine and cosine of an input angle @@ -161,14 +160,14 @@ pure module subroutine orbel_scget(angle, sx, cx) return - end subroutine orbel_scget + end subroutine swiftest_orbel_scget !********************************************************************** ! Code converted to Modern Fortran by David A. Minton ! Date: 2020-06-29 !********************************************************************** - ! ORBEL_SCHGET.F + ! swiftest_orbel_SCHGET.F !********************************************************************** ! PURPOSE: Given an angle, efficiently compute sinh and cosh. ! @@ -188,7 +187,7 @@ end subroutine orbel_scget ! DATE WRITTEN: May 6, 1992. ! REVISIONS: !********************************************************************** - pure subroutine orbel_schget(angle,shx,chx) + pure subroutine swiftest_orbel_schget(angle,shx,chx) real(DP), intent(in) :: angle real(DP), intent(out) :: shx,chx @@ -196,13 +195,13 @@ pure subroutine orbel_schget(angle,shx,chx) chx= sqrt(1._DP + shx * shx) return - end subroutine orbel_schget + end subroutine swiftest_orbel_schget !********************************************************************** ! Code converted to Modern Fortran by David A. Minton ! Date: 2020-06-29 - ! ! ORBEL_FLON.F + ! ! swiftest_orbel_FLON.F !********************************************************************** ! PURPOSE: Solves Kepler's eqn. for hyperbola using hybrid approach. ! @@ -210,7 +209,7 @@ end subroutine orbel_schget ! e ==> eccentricity anomaly. (real scalar) ! capn ==> hyperbola mean anomaly. (real scalar) ! Returns: - ! orbel_flon ==> eccentric anomaly. (real scalar) + ! swiftest_orbel_flon ==> eccentric anomaly. (real scalar) ! ! ALGORITHM: Uses power series for N in terms of F and Newton,s method ! REMARKS: ONLY GOOD FOR LOW VALUES OF N (N < 0.636*e -0.6) @@ -218,7 +217,7 @@ end subroutine orbel_schget ! DATE WRITTEN: May 26, 1992. ! REVISIONS: !********************************************************************** - real(DP) pure function orbel_flon(e,icapn) + real(DP) pure function swiftest_orbel_flon(e,icapn) implicit none real(DP), intent(in) :: e, icapn integer(I4B) :: iflag,i @@ -258,7 +257,7 @@ real(DP) pure function orbel_flon(e,icapn) biga = (-0.5_DP * b + sq)**(1.0_DP / 3.0_DP) bigb = -(+0.5_DP * b + sq)**(1.0_DP / 3.0_DP) x = biga + bigb - orbel_flon = x + swiftest_orbel_flon = x ! If capn is VSMALL (or zero) no need to go further than cubic even for ! e =1. if( capn >= VSMALL) then @@ -267,27 +266,27 @@ real(DP) pure function orbel_flon(e,icapn) f = a0 + x * (a1 + x2 * (a3 + x2 * (a5 + x2 * (a7 + x2 * (a9 + x2 * (a11 + x2)))))) fp = b1 + x2 * (b3 + x2 * (b5 + x2 * (b7 + x2 * (b9 + x2 * (b11 + 13 * x2))))) dx = -f / fp - orbel_flon = x + dx + swiftest_orbel_flon = x + dx ! if we have converged here there's no point in going on if(abs(dx) <= VSMALL) exit - x = orbel_flon + x = swiftest_orbel_flon end do end if ! normal return here, but check if capn was originally negative if(iflag == 1) then - orbel_flon = -orbel_flon + swiftest_orbel_flon = -orbel_flon capn = -capn end if return - end function orbel_flon + end function swiftest_orbel_flon !********************************************************************** ! Code converted to Modern Fortran by David A. Minton ! Date: 2020-06-29 - ! ORBEL_FGET.F + ! swiftest_orbel_FGET.F !********************************************************************** ! PURPOSE: Solves Kepler's eqn. for hyperbola using hybrid approach. ! @@ -295,7 +294,7 @@ end function orbel_flon ! e ==> eccentricity anomaly. (real scalar) ! capn ==> hyperbola mean anomaly. (real scalar) ! Returns: - ! orbel_fget ==> eccentric anomaly. (real scalar) + ! swiftest_orbel_fget ==> eccentric anomaly. (real scalar) ! ! ALGORITHM: Based on pp. 70-72 of Fitzpatrick's book "Principles of ! Cel. Mech. ". Quartic convergence from Danby's book. @@ -304,7 +303,7 @@ end function orbel_flon ! DATE WRITTEN: May 11, 1992. ! REVISIONS: 2/26/93 hfl !********************************************************************** - real(DP) pure function orbel_fget(e,capn) + real(DP) pure function swiftest_orbel_fget(e,capn) implicit none real(DP), intent(in) :: e,capn @@ -329,10 +328,10 @@ real(DP) pure function orbel_fget(e,capn) x = log(tmp) end if - orbel_fget = x + swiftest_orbel_fget = x do i = 1, IMAX - call orbel_schget(x,shx,chx) + call swiftest_orbel_schget(x,shx,chx) esh = e * shx ech = e * chx f = esh - x - capn @@ -343,21 +342,21 @@ real(DP) pure function orbel_fget(e,capn) dx = -f / fp dx = -f / (fp + dx * fpp / 2._DP) dx = -f / (fp + dx * fpp / 2._DP + dx**2 * fppp / 6._DP) - orbel_fget = x + dx + swiftest_orbel_fget = x + dx ! if we have converged here there's no point in going on if(abs(dx) <= VSMALL) return - x = orbel_fget + x = swiftest_orbel_fget end do !write(*,*) 'fget : returning without complete convergence' return - end function orbel_fget + end function swiftest_orbel_fget !********************************************************************** ! Code converted to Modern Fortran by David A. Minton ! Date: 2020-06-29 - ! ORBEL_ZGET.F + ! swiftest_orbel_ZGET.F !********************************************************************** ! PURPOSE: Solves the equivalent of Kepler's eqn. for a parabola ! given Q (Fitz. notation.) @@ -365,7 +364,7 @@ end function orbel_fget ! Input: ! q ==> parabola mean anomaly. (real scalar) ! Returns: - ! orbel_zget ==> eccentric anomaly. (real scalar) + ! swiftest_orbel_zget ==> eccentric anomaly. (real scalar) ! ! ALGORITHM: p. 70-72 of Fitzpatrick's book "Princ. of Cel. Mech." ! REMARKS: For a parabola we can solve analytically. @@ -374,7 +373,7 @@ end function orbel_fget ! REVISIONS: May 27 - corrected it for negative Q and use power ! series for small Q. !********************************************************************** - real(DP) pure function orbel_zget(iq) + real(DP) pure function swiftest_orbel_zget(iq) implicit none real(DP), intent(in) :: iq @@ -391,26 +390,26 @@ real(DP) pure function orbel_zget(iq) end if if (q < 1.e-3_DP) then - orbel_zget = q * (1._DP - (q**2 / 3._DP) * (1._DP - q**2)) + swiftest_orbel_zget = q * (1._DP - (q**2 / 3._DP) * (1._DP - q**2)) else x = 0.5_DP * (3 * q + sqrt(9 * q**2 + 4._DP)) tmp = x**(1._DP / 3._DP) - orbel_zget = tmp - 1._DP / tmp + swiftest_orbel_zget = tmp - 1._DP / tmp end if if(iflag == 1) then - orbel_zget = -orbel_zget + swiftest_orbel_zget = -orbel_zget q = -q end if return - end function orbel_zget + end function swiftest_orbel_zget !********************************************************************** ! Code converted to Modern Fortran by David A. Minton ! Date: 2020-06-29 - ! ORBEL_ESOLMD.F + ! swiftest_orbel_ESOLMD.F !********************************************************************** ! PURPOSE: Solves Kepler's eqn. e is ecc. m is mean anomaly. ! @@ -418,7 +417,7 @@ end function orbel_zget ! e ==> eccentricity anomaly. (real scalar) ! m ==> mean anomaly. (real scalar) ! Returns: - ! orbel_esolmd ==> eccentric anomaly. (real scalar) + ! swiftest_orbel_esolmd ==> eccentric anomaly. (real scalar) ! ! ALGORITHM: Some sort of quartic convergence from Wisdom. ! REMARKS: ONLY GOOD FOR SMALL ECCENTRICITY SINCE IT ONLY @@ -429,7 +428,7 @@ end function orbel_zget ! DATE WRITTEN: May 7, 1992. ! REVISIONS: 2/26/93 hfl !********************************************************************** - real(DP) pure function orbel_esolmd(e,m) + real(DP) pure function swiftest_orbel_esolmd(e,m) implicit none real(DP), intent(in) :: e @@ -441,10 +440,10 @@ real(DP) pure function orbel_esolmd(e,m) !... function to solve kepler's eqn for e (here called !... x) for given e and m. returns value of x. - call orbel_scget(m,sm,cm) + call swiftest_orbel_scget(m,sm,cm) x = m + e * sm * (1._DP + e * ( cm + e * (1._DP - 1.5_DP * sm**2))) - call orbel_scget(x,sx,cx) + call swiftest_orbel_scget(x,sx,cx) es = e * sx ec = e * cx f = x - es - m @@ -455,16 +454,16 @@ real(DP) pure function orbel_esolmd(e,m) dx = -f / (fp + dx * fpp / 2._DP) dx = -f / (fp + dx * fpp / 2._DP + dx**2 * fppp / 6._DP) - orbel_esolmd = x + dx + swiftest_orbel_esolmd = x + dx return - end function orbel_esolmd + end function swiftest_orbel_esolmd !********************************************************************** ! Code converted to Modern Fortran by David A. Minton ! Date: 2020-06-29 - ! ORBEL_EHIE.F + ! swiftest_orbel_EHIE.F !********************************************************************** ! PURPOSE: Solves Kepler's eqn. e is ecc. m is mean anomaly. ! @@ -472,7 +471,7 @@ end function orbel_esolmd ! e ==> eccentricity anomaly. (real scalar) ! m ==> mean anomaly. (real scalar) ! Returns: - ! orbel_ehybrid ==> eccentric anomaly. (real scalar) + ! swiftest_orbel_ehybrid ==> eccentric anomaly. (real scalar) ! ! ALGORITHM: Use Danby's quartic for 3 iterations. ! Eqn. is f(x) = x - e*sin(x+M). Note that @@ -484,7 +483,7 @@ end function orbel_esolmd ! DATE WRITTEN: May 25,1992. ! REVISIONS: !********************************************************************** - real(DP) pure function orbel_ehie(e,im) + real(DP) pure function swiftest_orbel_ehie(e,im) implicit none real(DP), intent(in) :: e,im @@ -512,7 +511,7 @@ real(DP) pure function orbel_ehie(e,im) ! iteration loop do niter =1,NMAX - call orbel_scget(x + m,sa,ca) + call swiftest_orbel_scget(x + m,sa,ca) esa = e * sa eca = e * ca f = x - esa @@ -523,21 +522,21 @@ real(DP) pure function orbel_ehie(e,im) x = x + dx end do - orbel_ehie = m + x + swiftest_orbel_ehie = m + x if (iflag == 1) then - orbel_ehie = TWOPI - orbel_ehie + swiftest_orbel_ehie = TWOPI - swiftest_orbel_ehie m = TWOPI - m end if return - end function orbel_ehie + end function swiftest_orbel_ehie !********************************************************************** ! Code converted to Modern Fortran by David A. Minton ! Date: 2020-06-29 - ! ORBEL_EGET.F + ! swiftest_orbel_EGET.F !********************************************************************** ! PURPOSE: Solves Kepler's eqn. e is ecc. m is mean anomaly. ! @@ -545,7 +544,7 @@ end function orbel_ehie ! e ==> eccentricity anomaly. (real scalar) ! m ==> mean anomaly. (real scalar) ! Returns: - ! orbel_eget ==> eccentric anomaly. (real scalar) + ! swiftest_orbel_eget ==> eccentric anomaly. (real scalar) ! ! ALGORITHM: Quartic convergence from Danby ! REMARKS: For results very near roundoff, give it M between @@ -559,7 +558,7 @@ end function orbel_ehie ! with the premise that it will only be called if ! we have an ellipse with e between 0.15 and 0.8 !********************************************************************** - real(DP) pure function orbel_eget(e,m) + real(DP) pure function swiftest_orbel_eget(e,m) implicit none real(DP), intent(in) :: e,m @@ -571,13 +570,13 @@ real(DP) pure function orbel_eget(e,m) ! may 21 : for e < 0.18 use esolmd for speed and sufficient accuracy ! may 21 : for e > 0.8 use ehie - this one may not converge fast enough. - call orbel_scget(m,sm,cm) + call swiftest_orbel_scget(m,sm,cm) ! begin with a guess accurate to order ecc**3 x = m + e * sm * ( 1._DP + e * (cm + e * (1._DP - 1.5_DP * sm * sm))) ! go through one iteration for improved estimate - call orbel_scget(x,sx,cx) + call swiftest_orbel_scget(x,sx,cx) es = e * sx ec = e * cx f = x - es - m @@ -587,14 +586,14 @@ real(DP) pure function orbel_eget(e,m) dx = -f / fp dx = -f / (fp + dx * fpp / 2._DP) dx = -f / (fp + dx * fpp / 2._DP + dx*2 * fppp / 6._DP) - orbel_eget = x + dx + swiftest_orbel_eget = x + dx ! do another iteration. ! for m between 0 and 2*pi this seems to be enough to ! get near roundoff error for eccentricities between 0 and 0.8 - x = orbel_eget - call orbel_scget(x,sx,cx) + x = swiftest_orbel_eget + call swiftest_orbel_scget(x,sx,cx) es = e * sx ec = e * cx f = x - es - m @@ -605,16 +604,16 @@ real(DP) pure function orbel_eget(e,m) dx = -f / (fp + dx * fpp / 2._DP) dx = -f / (fp + dx * fpp / 2._DP + dx**2 * fppp / 6._DP) - orbel_eget = x + dx + swiftest_orbel_eget = x + dx return - end function orbel_eget + end function swiftest_orbel_eget !********************************************************************** ! Code converted to Modern Fortran by David A. Minton ! Date: 2020-06-29 - ! ORBEL_EHYBRID.F + ! swiftest_orbel_EHYBRID.F !********************************************************************** ! PURPOSE: Solves Kepler's eqn. e is ecc. m is mean anomaly. ! @@ -622,7 +621,7 @@ end function orbel_eget ! e ==> eccentricity anomaly. (real scalar) ! m ==> mean anomaly. (real scalar) ! Returns: - ! orbel_ehybrid ==> eccentric anomaly. (real scalar) + ! swiftest_orbel_ehybrid ==> eccentric anomaly. (real scalar) ! ! ALGORITHM: For e < 0.18 uses fast routine ESOLMD ! For larger e but less than 0.8, uses EGET @@ -632,28 +631,28 @@ end function orbel_eget ! DATE WRITTEN: May 25,1992. ! REVISIONS: 2/26/93 hfl !********************************************************************** - real(DP) pure function orbel_ehybrid(e,m) + real(DP) pure function swiftest_orbel_ehybrid(e,m) implicit none real(DP), intent(in) :: e,m - !real(DP) :: orbel_esolmd,orbel_eget,orbel_ehie + !real(DP) :: swiftest_orbel_esolmd,orbel_eget,orbel_ehie if (e < 0.18_DP) then - orbel_ehybrid = orbel_esolmd(e,m) + swiftest_orbel_ehybrid = swiftest_orbel_esolmd(e,m) else if( e <= 0.8_DP) then - orbel_ehybrid = orbel_eget(e,m) + swiftest_orbel_ehybrid = swiftest_orbel_eget(e,m) else - orbel_ehybrid = orbel_ehie(e,m) + swiftest_orbel_ehybrid = swiftest_orbel_ehie(e,m) end if end if return - end function orbel_ehybrid + end function swiftest_orbel_ehybrid !********************************************************************** ! Code converted to Modern Fortran by David A. Minton ! Date: 2020-06-29 - ! ORBEL_FHYBRID.F + ! swiftest_orbel_FHYBRID.F !********************************************************************** ! PURPOSE: Solves Kepler's eqn. for hyperbola using hybrid approach. ! @@ -661,7 +660,7 @@ end function orbel_ehybrid ! e ==> eccentricity anomaly. (real scalar) ! n ==> hyperbola mean anomaly. (real scalar) ! Returns: - ! orbel_fhybrid ==> eccentric anomaly. (real scalar) + ! swiftest_orbel_fhybrid ==> eccentric anomaly. (real scalar) ! ! ALGORITHM: For abs(N) < 0.636*ecc -0.6 , use FLON ! For larger N, uses FGET @@ -671,7 +670,7 @@ end function orbel_ehybrid ! REVISIONS:: ! REVISIONS: 2/26/93 hfl !********************************************************************** - real(DP) pure function orbel_fhybrid(e,n) + real(DP) pure function swiftest_orbel_fhybrid(e,n) implicit none real(DP), intent(in) :: e,n @@ -681,16 +680,16 @@ real(DP) pure function orbel_fhybrid(e,n) if(n < 0._DP) abn = -abn if(abn < 0.636_DP * e -0.6_DP) then - orbel_fhybrid = orbel_flon(e,n) + swiftest_orbel_fhybrid = swiftest_orbel_flon(e,n) else - orbel_fhybrid = orbel_fget(e,n) + swiftest_orbel_fhybrid = swiftest_orbel_fget(e,n) end if return - end function orbel_fhybrid + end function swiftest_orbel_fhybrid - pure module subroutine orbel_xv2aeq(mu, px, py, pz, vx, vy, vz, a, e, q) + pure elemental module subroutine swiftest_orbel_xv2aeq(mu, px, py, pz, vx, vy, vz, a, e, q) !! author: David A. Minton !! !! Compute semimajor axis, eccentricity, and pericentric distance from relative Cartesian position and velocity @@ -752,10 +751,10 @@ pure module subroutine orbel_xv2aeq(mu, px, py, pz, vx, vy, vz, a, e, q) return - end subroutine orbel_xv2aeq + end subroutine swiftest_orbel_xv2aeq - pure module subroutine orbel_xv2aqt(mu, px, py, pz, vx, vy, vz, a, q, capm, tperi) + pure module subroutine swiftest_orbel_xv2aqt(mu, px, py, pz, vx, vy, vz, a, q, capm, tperi) !! author: David A. Minton !! !! Compute semimajor axis, pericentric distance, mean anomaly, and time to nearest pericenter passage from @@ -861,10 +860,10 @@ pure module subroutine orbel_xv2aqt(mu, px, py, pz, vx, vy, vz, a, q, capm, tper return - end subroutine orbel_xv2aqt + end subroutine swiftest_orbel_xv2aqt - module subroutine orbel_xv2el_vec(self, cb) + module subroutine swiftest_orbel_xv2el_vec(self, cb) !! author: David A. Minton !! !! A wrapper method that converts all of the cartesian position and velocity vectors of a Swiftest body object to orbital elements. @@ -886,7 +885,7 @@ module subroutine orbel_xv2el_vec(self, cb) if (allocated(self%omega)) deallocate(self%omega); allocate(self%omega(self%nbody)) if (allocated(self%capm)) deallocate(self%capm); allocate(self%capm(self%nbody)) do concurrent (i = 1:self%nbody) - call orbel_xv2el(self%mu(i), self%rh(1,i), self%rh(2,i), self%rh(3,i), & + call swiftest_orbel_xv2el(self%mu(i), self%rh(1,i), self%rh(2,i), self%rh(3,i), & self%vh(1,i), self%vh(2,i), self%vh(3,i), & self%a(i), self%e(i), self%inc(i), & self%capom(i), self%omega(i), self%capm(i), & @@ -894,10 +893,10 @@ module subroutine orbel_xv2el_vec(self, cb) end do return - end subroutine orbel_xv2el_vec + end subroutine swiftest_orbel_xv2el_vec - pure module subroutine orbel_xv2el(mu, px, py, pz, vx, vy, vz, a, e, inc, capom, omega, capm, varpi, lam, f, cape, capf) + pure module subroutine swiftest_orbel_xv2el(mu, px, py, pz, vx, vy, vz, a, e, inc, capom, omega, capm, varpi, lam, f, cape, capf) !! author: David A. Minton !! !! Compute osculating orbital elements from relative Cartesian position and velocity @@ -1044,7 +1043,7 @@ pure module subroutine orbel_xv2el(mu, px, py, pz, vx, vy, vz, a, e, inc, capom, return - end subroutine orbel_xv2el + end subroutine swiftest_orbel_xv2el end submodule s_orbel diff --git a/src/setup/setup.f90 b/src/swiftest_procedures/swiftest_setup.f90 similarity index 67% rename from src/setup/setup.f90 rename to src/swiftest_procedures/swiftest_setup.f90 index df55a53e9..5e20ede68 100644 --- a/src/setup/setup.f90 +++ b/src/swiftest_procedures/swiftest_setup.f90 @@ -7,84 +7,83 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule (swiftest_classes) s_setup - use swiftest +submodule (swiftest) s_setup + use whm + use rmvs + use helio + use symba contains - module subroutine setup_construct_system(system, param) + module subroutine swiftest_setup_construct_system(system, param) !! author: David A. Minton !! !! Constructor for a Swiftest nbody system. Creates the nbody system object based on the user-input integrator !! implicit none ! Arguments - class(swiftest_nbody_system), allocatable, intent(inout) :: system !! Swiftest system object - class(swiftest_parameters), intent(inout) :: param !! Swiftest parameters + class(base_nbody_system), allocatable, intent(inout) :: system !! Swiftest system object + class(base_parameters), intent(inout) :: param !! Swiftest parameters ! Internals type(encounter_storage) :: encounter_history type(collision_storage) :: collision_history - allocate(swiftest_storage(param%dump_cadence) :: param%system_history) - allocate(netcdf_parameters :: param%system_history%nc) - call param%system_history%reset() - - select case(param%integrator) - case (BS) - write(*,*) 'Bulirsch-Stoer integrator not yet enabled' - case (HELIO) - allocate(helio_nbody_system :: system) - select type(system) - class is (helio_nbody_system) - allocate(helio_cb :: system%cb) - allocate(helio_pl :: system%pl) - allocate(helio_tp :: system%tp) - allocate(helio_tp :: system%tp_discards) - end select - case (RA15) - write(*,*) 'Radau integrator not yet enabled' - case (TU4) - write(*,*) 'TU4 integrator not yet enabled' - case (WHM) - allocate(whm_nbody_system :: system) - select type(system) - class is (whm_nbody_system) - allocate(whm_cb :: system%cb) - allocate(whm_pl :: system%pl) - allocate(whm_tp :: system%tp) - allocate(whm_tp :: system%tp_discards) - end select - case (RMVS) - allocate(rmvs_nbody_system :: system) - select type(system) - class is (rmvs_nbody_system) - allocate(rmvs_cb :: system%cb) - allocate(rmvs_pl :: system%pl) - allocate(rmvs_tp :: system%tp) - allocate(rmvs_tp :: system%tp_discards) - end select - case (SYMBA) - allocate(symba_nbody_system :: system) - select type(system) - class is (symba_nbody_system) - allocate(symba_cb :: system%cb) - allocate(symba_pl :: system%pl) - allocate(symba_tp :: system%tp) - allocate(symba_tp :: system%tp_discards) - allocate(symba_merger :: system%pl_adds) - allocate(symba_merger :: system%pl_discards) - allocate(symba_pltpenc :: system%pltpenc_list) - allocate(symba_plplenc :: system%plplenc_list) - allocate(symba_plplenc :: system%plplcollision_list) - - select type(param) - class is (symba_parameters) + select type(param) + class is (swiftest_parameters) + allocate(swiftest_storage(param%dump_cadence) :: param%system_history) + allocate(swiftest_io_netcdf_parameters :: param%system_history%nc) + call param%system_history%reset() + + select case(param%integrator) + case (INT_BS) + write(*,*) 'Bulirsch-Stoer integrator not yet enabled' + case (INT_HELIO) + allocate(helio_nbody_system :: system) + select type(system) + class is (helio_nbody_system) + allocate(helio_cb :: system%cb) + allocate(helio_pl :: system%pl) + allocate(helio_tp :: system%tp) + allocate(helio_tp :: system%tp_discards) + end select + case (INT_RA15) + write(*,*) 'Radau integrator not yet enabled' + case (INT_TU4) + write(*,*) 'INT_TU4 integrator not yet enabled' + case (INT_WHM) + allocate(whm_nbody_system :: system) + select type(system) + class is (whm_nbody_system) + allocate(whm_cb :: system%cb) + allocate(whm_pl :: system%pl) + allocate(whm_tp :: system%tp) + allocate(whm_tp :: system%tp_discards) + end select + case (INT_RMVS) + allocate(rmvs_nbody_system :: system) + select type(system) + class is (rmvs_nbody_system) + allocate(rmvs_cb :: system%cb) + allocate(rmvs_pl :: system%pl) + allocate(rmvs_tp :: system%tp) + allocate(rmvs_tp :: system%tp_discards) + end select + case (INT_SYMBA) + allocate(symba_nbody_system :: system) + select type(system) + class is (symba_nbody_system) + allocate(symba_cb :: system%cb) + allocate(symba_pl :: system%pl) + allocate(symba_tp :: system%tp) + allocate(symba_tp :: system%tp_discards) + allocate(symba_pl :: system%pl_adds) + allocate(symba_pl :: system%pl_discards) + allocate(collision_list_pltp :: system%pltp_encounter) + allocate(collision_list_plpl :: system%plpl_encounter) + allocate(collision_list_plpl :: system%plpl_collision) if (param%lfragmentation) then allocate(fraggle_system :: system%collision_system) - call system%collision_system%setup(param) - - allocate(symba_nbody_system :: system%collision_system%before) - allocate(symba_nbody_system :: system%collision_system%after) + call system%collision_system%setup(system) end if if (param%lenc_save_trajectory .or. param%lenc_save_closest) then @@ -94,7 +93,7 @@ module subroutine setup_construct_system(system, param) class is (encounter_io_parameters) nc%file_number = param%iloop / param%dump_cadence end select - allocate(param%encounter_history, source=encounter_history) + allocate(system%encounter_history, source=encounter_history) end if allocate(collision_io_parameters :: collision_history%nc) @@ -103,24 +102,24 @@ module subroutine setup_construct_system(system, param) class is (collision_io_parameters) nc%file_number = param%iloop / param%dump_cadence end select - allocate(param%collision_history, source=collision_history) - end select + allocate(system%collision_history, source=collision_history) + end select + case (INT_RINGMOONS) + write(*,*) 'RINGMOONS-SyMBA integrator not yet enabled' + case default + write(*,*) 'Unkown integrator',param%integrator + call util_exit(FAILURE) end select - case (RINGMOONS) - write(*,*) 'RINGMOONS-SyMBA integrator not yet enabled' - case default - write(*,*) 'Unkown integrator',param%integrator - call util_exit(FAILURE) end select return - end subroutine setup_construct_system + end subroutine swiftest_setup_construct_system - module subroutine setup_initialize_particle_info_system(self, param) + module subroutine swiftest_setup_initialize_particle_info_system(self, param) !! author: David A. Minton !! !! Setup up particle information metadata from initial conditions @@ -132,9 +131,11 @@ module subroutine setup_initialize_particle_info_system(self, param) ! Internals integer(I4B) :: i - associate(cb => self%cb, pl => self%pl, npl => self%pl%nbody, tp => self%tp, ntp => self%tp%nbody) + associate(pl => self%pl, npl => self%pl%nbody, tp => self%tp, ntp => self%tp%nbody) - call cb%info%set_value(particle_type=CB_TYPE_NAME, status="ACTIVE", origin_type="Initial conditions", & + if (.not. allocated(self%cb%info)) allocate(swiftest_particle_info :: self%cb%info) + + call self%cb%info%set_value(particle_type=CB_TYPE_NAME, status="ACTIVE", origin_type="Initial conditions", & origin_time=param%t0, origin_rh=[0.0_DP, 0.0_DP, 0.0_DP], origin_vh=[0.0_DP, 0.0_DP, 0.0_DP]) do i = 1, self%pl%nbody call pl%info(i)%set_value(particle_type=PL_TYPE_NAME, status="ACTIVE", origin_type="Initial conditions", & @@ -148,10 +149,10 @@ module subroutine setup_initialize_particle_info_system(self, param) end associate return - end subroutine setup_initialize_particle_info_system + end subroutine swiftest_setup_initialize_particle_info_system - module subroutine setup_initialize_system(self, param) + module subroutine swiftest_setup_initialize_system(self, param) !! author: David A. Minton !! !! Wrapper method to initialize a basic Swiftest nbody system from files @@ -183,10 +184,10 @@ module subroutine setup_initialize_system(self, param) end associate return - end subroutine setup_initialize_system + end subroutine swiftest_setup_initialize_system - module subroutine setup_body(self, n, param) + module subroutine swiftest_setup_body(self, n, param) !! author: David A. Minton !! !! Constructor for base Swiftest particle class. Allocates space for all particles and @@ -209,7 +210,7 @@ module subroutine setup_body(self, n, param) self%nbody = n if (n == 0) return - allocate(self%info(n)) + allocate(swiftest_particle_info :: self%info(n)) allocate(self%id(n)) allocate(self%status(n)) allocate(self%ldiscard(n)) @@ -222,6 +223,12 @@ module subroutine setup_body(self, n, param) allocate(self%ah(NDIM, n)) allocate(self%ir3h(n)) allocate(self%aobl(NDIM, n)) + if (param%lclose) then + allocate(self%lcollision(n)) + allocate(self%lencounter(n)) + self%lcollision(:) = .false. + self%lencounter(:) = .false. + end if self%id(:) = 0 do i = 1, n @@ -263,10 +270,10 @@ module subroutine setup_body(self, n, param) end if return - end subroutine setup_body + end subroutine swiftest_setup_body - module subroutine setup_pl(self, n, param) + module subroutine swiftest_setup_pl(self, n, param) !! author: David A. Minton !! !! Constructor for base Swiftest massive body class. Allocates space for all particles and @@ -295,10 +302,18 @@ module subroutine setup_pl(self, n, param) self%nplpl = 0 if (param%lclose) then + allocate(self%lmtiny(n)) + allocate(self%nplenc(n)) + allocate(self%ntpenc(n)) allocate(self%radius(n)) allocate(self%density(n)) + + self%lmtiny(:) = .false. + self%nplenc(:) = 0 + self%ntpenc(:) = 0 self%radius(:) = 0.0_DP self%density(:) = 1.0_DP + end if if (param%lrotation) then @@ -318,10 +333,10 @@ module subroutine setup_pl(self, n, param) end if return - end subroutine setup_pl + end subroutine swiftest_setup_pl - module subroutine setup_tp(self, n, param) + module subroutine swiftest_setup_tp(self, n, param) !! author: David A. Minton !! !! Constructor for base Swiftest test particle particle class. Allocates space for @@ -340,12 +355,14 @@ module subroutine setup_tp(self, n, param) allocate(self%isperi(n)) allocate(self%peri(n)) allocate(self%atp(n)) + allocate(self%nplenc(n)) self%isperi(:) = 0 self%peri(:) = 0.0_DP self%atp(:) = 0.0_DP + self%nplenc(:) = 0 return - end subroutine setup_tp + end subroutine swiftest_setup_tp end submodule s_setup diff --git a/src/swiftest_procedures/swiftest_util.f90 b/src/swiftest_procedures/swiftest_util.f90 new file mode 100644 index 000000000..40f614f42 --- /dev/null +++ b/src/swiftest_procedures/swiftest_util.f90 @@ -0,0 +1,4923 @@ +!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh +!! This file is part of Swiftest. +!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License +!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. +!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty +!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. +!! You should have received a copy of the GNU General Public License along with Swiftest. +!! If not, see: https://www.gnu.org/licenses. + +submodule (swiftest) s_util +contains + + module subroutine swiftest_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. + implicit none + ! 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) :: nnew + + if (.not. allocated(source)) return + + nnew = count(lsource_mask(1:nsrc)) + if (.not.allocated(arr)) then + allocate(arr(nold+nnew)) + else + call util_resize(arr, nold + nnew) + end if + + arr(nold + 1:nold + nnew) = pack(source(1:nsrc), lsource_mask(1:nsrc)) + + return + end subroutine swiftest_util_append_arr_char_string + + + module subroutine swiftest_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. + implicit none + ! 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) :: nnew + + if (.not. allocated(source)) return + + nnew = count(lsource_mask(1:nsrc)) + if (.not.allocated(arr)) then + allocate(arr(nold+nnew)) + else + call util_resize(arr, nold + nnew) + end if + + arr(nold + 1:nold + nnew) = pack(source(1:nsrc), lsource_mask(1:nsrc)) + + return + end subroutine swiftest_util_append_arr_DP + + + module subroutine swiftest_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. + implicit none + ! 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) :: nnew + + if (.not. allocated(source)) return + + nnew = count(lsource_mask(1:nsrc)) + if (.not.allocated(arr)) then + allocate(arr(NDIM,nold+nnew)) + else + call util_resize(arr, nold + nnew) + end if + + arr(1, nold + 1:nold + nnew) = pack(source(1,1:nsrc), lsource_mask(1:nsrc)) + arr(2, nold + 1:nold + nnew) = pack(source(2,1:nsrc), lsource_mask(1:nsrc)) + arr(3, nold + 1:nold + nnew) = pack(source(3,1:nsrc), lsource_mask(1:nsrc)) + + return + end subroutine swiftest_util_append_arr_DPvec + + + module subroutine swiftest_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. + implicit none + ! 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) :: nnew + + if (.not. allocated(source)) return + + nnew = count(lsource_mask(1:nsrc)) + if (.not.allocated(arr)) then + allocate(arr(nold+nnew)) + else + call util_resize(arr, nold + nnew) + end if + + arr(nold + 1:nold + nnew) = pack(source(1:nsrc), lsource_mask(1:nsrc)) + + return + end subroutine swiftest_util_append_arr_I4B + + + module subroutine swiftest_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(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: arr !! Destination array + type(swiftest_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) :: nnew, i + integer(I4B), dimension(:), allocatable :: idx + + if (.not. allocated(source)) return + + nnew = count(lsource_mask(1:nsrc)) + if (.not.allocated(arr)) then + allocate(arr(nold+nnew)) + else + call util_resize(arr, nold + nnew) + end if + + allocate(idx(nnew)) + + idx = pack([(i, i = 1, nsrc)], lsource_mask(1:nsrc)) + + call util_copy_particle_info_arr(source(1:nsrc), arr(nold+1:nold+nnew), idx) + + return + end subroutine swiftest_util_append_arr_info + + + module subroutine swiftest_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. + implicit none + ! 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) :: nnew + + if (.not. allocated(source)) return + + nnew = count(lsource_mask(1:nsrc)) + if (.not.allocated(arr)) then + allocate(arr(nold+nnew)) + else + call util_resize(arr, nold + nnew) + end if + + arr(nold + 1:nold + nnew) = pack(source(1:nsrc), lsource_mask(1:nsrc)) + + return + end subroutine swiftest_util_append_arr_logical + + + module subroutine swiftest_util_append_body(self, source, lsource_mask) + !! author: David A. Minton + !! + !! Append components from one Swiftest body object to another. + !! This method will automatically resize the destination body if it is too small + implicit none + ! Arguments + class(swiftest_body), intent(inout) :: self !! Swiftest body object + class(swiftest_body), intent(in) :: source !! Source object to append + logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + ! Internals + integer(I4B) :: nold, nsrc, nnew + + nold = self%nbody + nsrc = source%nbody + nnew = count(lsource_mask(1:nsrc)) + + call util_append(self%info, source%info, 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%rh, source%rh, nold, nsrc, lsource_mask) + call util_append(self%vh, source%vh, nold, nsrc, lsource_mask) + call util_append(self%rb, source%rb, 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) + + self%nbody = nold + nnew + + return + end subroutine swiftest_util_append_body + + + module subroutine swiftest_util_append_pl(self, source, lsource_mask) + !! author: David A. Minton + !! + !! Append components from one Swiftest body object to another. + !! This method will automatically resize the destination body if it is too small + implicit none + ! Arguments + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_body), intent(in) :: source !! Source object to append + logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + + select type(source) + class is (swiftest_pl) + associate(nold => self%nbody, nsrc => source%nbody) + 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%renc, source%renc, nold, nsrc, lsource_mask) + call util_append(self%radius, source%radius, nold, nsrc, lsource_mask) + call util_append(self%rbeg, source%rbeg, nold, nsrc, lsource_mask) + call util_append(self%rend, source%rend, 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) + + if (allocated(self%k_plpl)) deallocate(self%k_plpl) + + call util_append_body(self, source, lsource_mask) + end associate + class default + write(*,*) "Invalid object passed to the append method. Source must be of class swiftest_pl or its descendents" + call util_exit(FAILURE) + end select + + return + end subroutine swiftest_util_append_pl + + + module subroutine swiftest_util_append_tp(self, source, lsource_mask) + !! author: David A. Minton + !! + !! Append components from one Swiftest body object to another. + !! This method will automatically resize the destination body if it is too small + implicit none + ! Arguments + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + class(swiftest_body), intent(in) :: source !! Source object to append + logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to + + select type(source) + class is (swiftest_tp) + associate(nold => self%nbody, nsrc => source%nbody) + 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_body(self, source, 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) + end select + + return + end subroutine swiftest_util_append_tp + + + module subroutine swiftest_util_coord_h2b_pl(self, cb) + !! author: David A. Minton + !! + !! Convert massive bodies from heliocentric to barycentric coordinates (position and velocity) + !! + !! Adapted from David E. Kaufmann's Swifter routine coord_h2b.f90 + !! Adapted from Hal Levison's Swift routine coord_h2b.f + implicit none + ! Arguments + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object + ! Internals + integer(I4B) :: i + real(DP) :: Gmtot + real(DP), dimension(NDIM) :: xtmp, vtmp + + if (self%nbody == 0) return + associate(pl => self, npl => self%nbody) + Gmtot = cb%Gmass + xtmp(:) = 0.0_DP + vtmp(:) = 0.0_DP + do i = 1, npl + if (pl%status(i) == INACTIVE) cycle + Gmtot = Gmtot + pl%Gmass(i) + xtmp(:) = xtmp(:) + pl%Gmass(i) * pl%rh(:,i) + vtmp(:) = vtmp(:) + pl%Gmass(i) * pl%vh(:,i) + end do + cb%rb(:) = -xtmp(:) / Gmtot + cb%vb(:) = -vtmp(:) / Gmtot + do i = 1, npl + if (pl%status(i) == INACTIVE) cycle + pl%rb(:,i) = pl%rh(:,i) + cb%rb(:) + pl%vb(:,i) = pl%vh(:,i) + cb%vb(:) + end do + end associate + + return + end subroutine swiftest_util_coord_h2b_pl + + + module subroutine swiftest_util_coord_h2b_tp(self, cb) + !! author: David A. Minton + !! + !! Convert test particles from heliocentric to barycentric coordinates (position and velocity) + !! + !! Adapted from David E. Kaufmann's Swifter routine coord_h2b_tp.f90 + !! Adapted from Hal Levison's Swift routine coord_h2b_tp.f + implicit none + ! Arguments + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + class(swiftest_cb), intent(in) :: cb !! Swiftest central body object + ! Internals + integer(I4B) :: i + + if (self%nbody == 0) return + associate(tp => self, ntp => self%nbody) + do concurrent (i = 1:ntp, tp%status(i) /= INACTIVE) + tp%rb(:, i) = tp%rh(:, i) + cb%rb(:) + tp%vb(:, i) = tp%vh(:, i) + cb%vb(:) + end do + end associate + + return + end subroutine swiftest_util_coord_h2b_tp + + + module subroutine swiftest_util_coord_b2h_pl(self, cb) + !! author: David A. Minton + !! + !! Convert massive bodies from barycentric to heliocentric coordinates (position and velocity) + !! + !! Adapted from David E. Kaufmann's Swifter routine coord_b2h.f90 + !! Adapted from Hal Levison's Swift routine coord_b2h.f + implicit none + ! Arguments + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object + ! Internals + integer(I4B) :: i + + if (self%nbody == 0) return + + associate(pl => self, npl => self%nbody) + do concurrent (i = 1:npl, pl%status(i) /= INACTIVE) + pl%rh(:, i) = pl%rb(:, i) - cb%rb(:) + pl%vh(:, i) = pl%vb(:, i) - cb%vb(:) + end do + end associate + + return + end subroutine swiftest_util_coord_b2h_pl + + + module subroutine swiftest_util_coord_b2h_tp(self, cb) + !! author: David A. Minton + !! + !! Convert test particles from barycentric to heliocentric coordinates (position and velocity) + !! + !! Adapted from David E. Kaufmann's Swifter routine coord_b2h_tp.f90 + !! Adapted from Hal Levison's Swift routine coord_b2h_tp.f + implicit none + ! Arguments + class(swiftest_tp), intent(inout) :: self !! Swiftest massive body object + class(swiftest_cb), intent(in) :: cb !! Swiftest central body object + ! Internals + integer(I4B) :: i + + if (self%nbody == 0) return + + associate(tp => self, ntp => self%nbody) + do concurrent(i = 1:ntp, tp%status(i) /= INACTIVE) + tp%rh(:, i) = tp%rb(:, i) - cb%rb(:) + tp%vh(:, i) = tp%vb(:, i) - cb%vb(:) + end do + end associate + + return + end subroutine swiftest_util_coord_b2h_tp + + + module subroutine swiftest_util_coord_vb2vh_pl(self, cb) + !! author: David A. Minton + !! + !! Convert massive bodies from barycentric to heliocentric coordinates (velocity only) + !! + !! Adapted from David E. Kaufmann's Swifter routine coord_vb2vh.f90 + !! Adapted from Hal Levison's Swift routine coord_vb2vh.f + implicit none + ! Arguments + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object + ! Internals + integer(I4B) :: i + + if (self%nbody == 0) return + + associate(pl => self, npl => self%nbody) + cb%vb(:) = 0.0_DP + do i = npl, 1, -1 + cb%vb(:) = cb%vb(:) - pl%Gmass(i) * pl%vb(:, i) / cb%Gmass + end do + do concurrent(i = 1:npl) + pl%vh(:, i) = pl%vb(:, i) - cb%vb(:) + end do + end associate + + return + end subroutine swiftest_util_coord_vb2vh_pl + + + module subroutine swiftest_util_coord_vb2vh_tp(self, vbcb) + !! author: David A. Minton + !! + !! Convert test particles from barycentric to heliocentric coordinates (velocity only) + !! + !! Adapted from David E. Kaufmann's Swifter routine coord_vb2vh_tp.f90 + !! Adapted from Hal Levison's Swift routine coord_vb2h_tp.f + implicit none + ! Arguments + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + real(DP), dimension(:), intent(in) :: vbcb !! Barycentric velocity of the central body + + if (self%nbody == 0) return + + associate(tp => self, ntp => self%nbody) + where (tp%lmask(1:ntp)) + tp%vh(1, 1:ntp) = tp%vb(1, 1:ntp) - vbcb(1) + tp%vh(2, 1:ntp) = tp%vb(2, 1:ntp) - vbcb(2) + tp%vh(3, 1:ntp) = tp%vb(3, 1:ntp) - vbcb(3) + end where + end associate + + return + end subroutine swiftest_util_coord_vb2vh_tp + + + module subroutine swiftest_util_coord_vh2vb_pl(self, cb) + !! author: David A. Minton + !! + !! Convert massive bodies from heliocentric to barycentric coordinates (velocity only) + !! + !! Adapted from David E. Kaufmann's Swifter routine coord_vh2vb.f90 + !! Adapted from Hal Levison's Swift routine coord_vh2b.f + implicit none + ! Arguments + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object + ! Internals + integer(I4B) :: i + real(DP) :: Gmtot + + if (self%nbody == 0) return + + associate(pl => self, npl => self%nbody) + Gmtot = cb%Gmass + sum(pl%Gmass(1:npl)) + cb%vb(:) = 0.0_DP + do i = 1, npl + cb%vb(:) = cb%vb(:) - pl%Gmass(i) * pl%vh(:, i) + end do + cb%vb(:) = cb%vb(:) / Gmtot + do concurrent(i = 1:npl) + pl%vb(:, i) = pl%vh(:, i) + cb%vb(:) + end do + end associate + + return + end subroutine swiftest_util_coord_vh2vb_pl + + + module subroutine swiftest_util_coord_vh2vb_tp(self, vbcb) + !! author: David A. Minton + !! + !! Convert test particles from heliocentric to barycentric coordinates (velocity only) + !! + !! Adapted from David E. Kaufmann's Swifter routine coord_vh2vb_tp.f90 + !! Adapted from Hal Levison's Swift routine coord_vh2b_tp.f + implicit none + ! Arguments + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + real(DP), dimension(:), intent(in) :: vbcb !! Barycentric velocity of the central body + + if (self%nbody == 0) return + + associate(tp => self, ntp => self%nbody) + where (tp%lmask(1:ntp)) + tp%vb(1, 1:ntp) = tp%vh(1, 1:ntp) + vbcb(1) + tp%vb(2, 1:ntp) = tp%vh(2, 1:ntp) + vbcb(2) + tp%vb(3, 1:ntp) = tp%vh(3, 1:ntp) + vbcb(3) + end where + end associate + + return + end subroutine swiftest_util_coord_vh2vb_tp + + + module subroutine swiftest_util_coord_rh2rb_pl(self, cb) + !! author: David A. Minton + !! + !! Convert position vectors of massive bodies from heliocentric to barycentric coordinates (position only) + !! + !! Adapted from David E. Kaufmann's Swifter routine coord_h2b.f90 + !! Adapted from Hal Levison's Swift routine coord_h2b.f + implicit none + ! Arguments + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object + ! Internals + integer(I4B) :: i + real(DP) :: Gmtot + real(DP), dimension(NDIM) :: xtmp + + if (self%nbody == 0) return + associate(pl => self, npl => self%nbody) + Gmtot = cb%Gmass + xtmp(:) = 0.0_DP + do i = 1, npl + if (pl%status(i) == INACTIVE) cycle + Gmtot = Gmtot + pl%Gmass(i) + xtmp(:) = xtmp(:) + pl%Gmass(i) * pl%rh(:,i) + end do + cb%rb(:) = -xtmp(:) / Gmtot + do i = 1, npl + if (pl%status(i) == INACTIVE) cycle + pl%rb(:,i) = pl%rh(:,i) + cb%rb(:) + end do + end associate + + return + end subroutine swiftest_util_coord_rh2rb_pl + + + module subroutine swiftest_util_coord_rh2rb_tp(self, cb) + !! author: David A. Minton + !! + !! Convert test particles from heliocentric to barycentric coordinates (position only) + !! + !! Adapted from David E. Kaufmann's Swifter routine coord_h2b_tp.f90 + !! Adapted from Hal Levison's Swift routine coord_h2b_tp.f + implicit none + ! Arguments + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + class(swiftest_cb), intent(in) :: cb !! Swiftest central body object + ! Internals + integer(I4B) :: i + + if (self%nbody == 0) return + associate(tp => self, ntp => self%nbody) + do concurrent (i = 1:ntp, tp%status(i) /= INACTIVE) + tp%rb(:, i) = tp%rh(:, i) + cb%rb(:) + end do + end associate + + return + end subroutine swiftest_util_coord_rh2rb_tp + + + module subroutine swiftest_util_copy_particle_info(self, source) + !! author: David A. Minton + !! + !! Copies one set of information object components into another, component-by-component + implicit none + class(swiftest_particle_info), intent(inout) :: self + class(swiftest_particle_info), intent(in) :: source + + call self%set_value(& + name = source%name, & + particle_type = source%particle_type, & + status = source%status, & + origin_type = source%origin_type, & + origin_time = source%origin_time, & + collision_id = source%collision_id, & + origin_rh = source%origin_rh(:), & + origin_vh = source%origin_vh(:), & + discard_time = source%discard_time, & + discard_rh = source%discard_rh(:), & + discard_vh = source%discard_vh(:), & + discard_body_id = source%discard_body_id & + ) + + return + end subroutine swiftest_util_copy_particle_info + + + module subroutine swiftest_util_copy_particle_info_arr(source, dest, idx) + !! author: David A. Minton + !! + !! Copies contents from an array of one particle information objects to another. + implicit none + class(swiftest_particle_info), dimension(:), intent(in) :: source !! Source object to copy into + class(swiftest_particle_info), dimension(:), intent(inout) :: dest !! Swiftest body object with particle metadata information object + integer(I4B), dimension(:), intent(in), optional :: idx !! Optional array of indices to draw the source object + ! Internals + integer(I4B) :: i, j, n, nsource, ndest + + if (size(source) == 0) return + + if (present(idx)) then + n = size(idx) + else + n = size(source) + end if + + nsource = size(source) + ndest = size(dest) + + if ((n == 0) .or. (n > ndest) .or. (n > nsource)) then + write(*,*) 'Particle info copy operation failed. n, nsource, ndest: ',n, nsource, ndest + return + end if + + do i = 1, n + if (present(idx)) then + j = idx(i) + else + j = i + end if + call dest(i)%copy(source(j)) + end do + + return + end subroutine swiftest_util_copy_particle_info_arr + + + module subroutine swiftest_util_dealloc_body(self) + !! author: David A. Minton + !! + !! Finalize the swiftest body object - deallocates all allocatables + implicit none + ! Argument + class(swiftest_body), intent(inout) :: self + + if (allocated(self%info)) deallocate(self%info) + if (allocated(self%id)) deallocate(self%id) + if (allocated(self%status)) deallocate(self%status) + if (allocated(self%ldiscard)) deallocate(self%ldiscard) + if (allocated(self%lcollision)) deallocate(self%lcollision) + if (allocated(self%lencounter)) deallocate(self%lencounter) + if (allocated(self%lmask)) deallocate(self%lmask) + if (allocated(self%mu)) deallocate(self%mu) + if (allocated(self%rh)) deallocate(self%rh) + if (allocated(self%vh)) deallocate(self%vh) + if (allocated(self%rb)) deallocate(self%rb) + if (allocated(self%vb)) deallocate(self%vb) + if (allocated(self%ah)) deallocate(self%ah) + if (allocated(self%aobl)) deallocate(self%aobl) + if (allocated(self%agr)) deallocate(self%agr) + if (allocated(self%atide)) deallocate(self%atide) + if (allocated(self%ir3h)) deallocate(self%ir3h) + if (allocated(self%a)) deallocate(self%a) + if (allocated(self%e)) deallocate(self%e) + if (allocated(self%e)) deallocate(self%e) + if (allocated(self%inc)) deallocate(self%inc) + if (allocated(self%capom)) deallocate(self%capom) + if (allocated(self%omega)) deallocate(self%omega) + if (allocated(self%capm)) deallocate(self%capm) + + return + end subroutine swiftest_util_dealloc_body + + + module subroutine swiftest_util_dealloc_kin(self) + !! author: David A. Minton + !! + !! Deallocates all allocatabale arrays + implicit none + ! Arguments + class(swiftest_kinship), intent(inout) :: self !! Swiftest kinship object + + if (allocated(self%child)) deallocate(self%child) + + return + end subroutine swiftest_util_dealloc_kin + + + + module subroutine swiftest_util_dealloc_pl(self) + !! author: David A. Minton + !! + !! Finalize the swiftest massive body object - deallocates all allocatables + implicit none + ! Argument + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + ! Internals + integer(I4B) :: i + + if (allocated(self%mass)) deallocate(self%mass) + if (allocated(self%Gmass)) deallocate(self%Gmass) + if (allocated(self%rhill)) deallocate(self%rhill) + if (allocated(self%renc)) deallocate(self%renc) + if (allocated(self%radius)) deallocate(self%radius) + if (allocated(self%density)) deallocate(self%density) + if (allocated(self%rot)) deallocate(self%rot) + if (allocated(self%Ip)) deallocate(self%Ip) + if (allocated(self%k2)) deallocate(self%k2) + if (allocated(self%Q)) deallocate(self%Q) + if (allocated(self%tlag)) deallocate(self%tlag) + if (allocated(self%k_plpl)) deallocate(self%k_plpl) + if (allocated(self%lmtiny)) deallocate(self%lmtiny) + if (allocated(self%nplenc)) deallocate(self%nplenc) + if (allocated(self%ntpenc)) deallocate(self%ntpenc) + + + if (allocated(self%kin)) then + do i = 1, self%nbody + call self%kin(i)%dealloc() + end do + deallocate(self%kin) + end if + + call util_dealloc_body(self) + + return + end subroutine swiftest_util_dealloc_pl + + + module subroutine swiftest_util_dealloc_tp(self) + !! author: David A. Minton + !! + !! Finalize the swiftest test particle object - deallocates all allocatables + implicit none + ! Argument + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + + if (allocated(self%nplenc)) deallocate(self%nplenc) + if (allocated(self%isperi)) deallocate(self%isperi) + if (allocated(self%peri)) deallocate(self%peri) + if (allocated(self%atp)) deallocate(self%atp) + if (allocated(self%k_pltp)) deallocate(self%k_pltp) + + call util_dealloc_body(self) + + return + end subroutine swiftest_util_dealloc_tp + + + module subroutine swiftest_util_exit(code) + !! author: David A. Minton + !! + !! Print termination message and exit program + !! + !! Adapted from David E. Kaufmann's Swifter routine: util_exit.f90 + !! Adapted from Hal Levison's Swift routine util_exit.f + implicit none + ! Arguments + integer(I4B), intent(in) :: code + ! Internals + character(*), parameter :: BAR = '("------------------------------------------------")' + character(*), parameter :: SUCCESS_MSG = '(/, "Normal termination of Swiftest (version ", f3.1, ")")' + character(*), parameter :: FAIL_MSG = '(/, "Terminating Swiftest (version ", f3.1, ") due to error!!")' + character(*), parameter :: USAGE_MSG = '("Usage: swiftest [bs|helio|ra15|rmvs|symba|tu4|whm] [standard|compact|progress|NONE]")' + character(*), parameter :: HELP_MSG = USAGE_MSG + + select case(code) + case(SUCCESS) + write(*, SUCCESS_MSG) VERSION_NUMBER + write(*, BAR) + case(USAGE) + write(*, USAGE_MSG) + case(HELP) + write(*, HELP_MSG) + case default + write(*, FAIL_MSG) VERSION_NUMBER + write(*, BAR) + error stop + end select + + stop + + end subroutine swiftest_util_exit + + + module subroutine swiftest_util_fill_arr_char_string(keeps, inserts, lfill_list) + !! author: David A. Minton + !! + !! Performs a fill operation on a single array of type character strings + !! This is the inverse of a spill operation + implicit none + ! Arguments + character(len=STRMAX), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + character(len=STRMAX), 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 swiftest_util_fill_arr_char_string + + + module subroutine swiftest_util_fill_arr_DP(keeps, inserts, lfill_list) + !! author: David A. Minton + !! + !! Performs a fill operation on a single array of type DP + !! This is the inverse of a spill operation + implicit none + ! Arguments + real(DP), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + real(DP), 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 swiftest_util_fill_arr_DP + + module subroutine swiftest_util_fill_arr_DPvec(keeps, inserts, lfill_list) + !! author: David A. Minton + !! + !! Performs a fill operation on a single array of DP vectors with shape (NDIM, n) + !! This is the inverse of a spill operation + implicit none + ! Arguments + real(DP), dimension(:,:), allocatable, intent(inout) :: keeps !! Array of values to keep + real(DP), 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 + ! Internals + integer(I4B) :: i + + if (.not.allocated(keeps) .or. .not.allocated(inserts)) return + + do i = 1, NDIM + keeps(i,:) = unpack(keeps(i,:), .not.lfill_list(:), keeps(i,:)) + keeps(i,:) = unpack(inserts(i,:), lfill_list(:), keeps(i,:)) + end do + + return + end subroutine swiftest_util_fill_arr_DPvec + + module subroutine swiftest_util_fill_arr_I4B(keeps, inserts, lfill_list) + !! author: David A. Minton + !! + !! Performs a fill operation on a single array of type I4B + !! This is the inverse of a spill operation + implicit none + ! Arguments + integer(I4B), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + integer(I4B), 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 swiftest_util_fill_arr_I4B + + + module subroutine swiftest_util_fill_arr_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(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + type(swiftest_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 + ! Internals + integer(I4B), dimension(:), allocatable :: insert_idx + integer(I4B) :: i, nkeep, ninsert + + if (.not.allocated(keeps) .or. .not.allocated(inserts)) return + + nkeep = size(keeps) + ninsert = count(lfill_list) + + allocate(insert_idx(ninsert)) + + insert_idx(:) = pack([(i, i = 1, nkeep)], lfill_list) + call util_copy_particle_info_arr(inserts, keeps, insert_idx) + + return + end subroutine swiftest_util_fill_arr_info + + + module subroutine swiftest_util_fill_arr_logical(keeps, inserts, lfill_list) + !! author: David A. Minton + !! + !! Performs a fill operation on a single array of logicals + !! This is the inverse of a spill operation + implicit none + ! Arguments + logical, dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + logical, 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 swiftest_util_fill_arr_logical + + + module subroutine swiftest_util_fill_body(self, inserts, lfill_list) + !! author: David A. Minton + !! + !! Insert new Swiftest generic particle structure into an old one. + !! This is the inverse of a spill operation. + implicit none + ! Arguments + class(swiftest_body), intent(inout) :: self !! Swiftest generic body object + class(swiftest_body), intent(in) :: inserts !! Inserted object + logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps + + ! For each component, pack the discarded bodies into the discard object and do the inverse with the keeps + !> Fill all the common components + associate(keeps => self) + call util_fill(keeps%id, inserts%id, lfill_list) + call util_fill(keeps%info, inserts%info, lfill_list) + call util_fill(keeps%lmask, inserts%lmask, lfill_list) + call util_fill(keeps%status, inserts%status, lfill_list) + call util_fill(keeps%ldiscard, inserts%ldiscard, lfill_list) + call util_fill(keeps%lcollision, inserts%lcollision, lfill_list) + call util_fill(keeps%lencounter, inserts%lencounter, lfill_list) + call util_fill(keeps%mu, inserts%mu, lfill_list) + call util_fill(keeps%rh, inserts%rh, lfill_list) + call util_fill(keeps%vh, inserts%vh, lfill_list) + call util_fill(keeps%rb, inserts%rb, lfill_list) + call util_fill(keeps%vb, inserts%vb, lfill_list) + call util_fill(keeps%ah, inserts%ah, lfill_list) + call util_fill(keeps%aobl, inserts%aobl, lfill_list) + call util_fill(keeps%agr, inserts%agr, lfill_list) + call util_fill(keeps%atide, inserts%atide, lfill_list) + call util_fill(keeps%ir3h, inserts%ir3h, 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) + call util_fill(keeps%a, inserts%a, lfill_list) + call util_fill(keeps%e, inserts%e, lfill_list) + call util_fill(keeps%inc, inserts%inc, lfill_list) + call util_fill(keeps%capom, inserts%capom, lfill_list) + call util_fill(keeps%omega, inserts%omega, lfill_list) + call util_fill(keeps%capm, inserts%capm, lfill_list) + + ! This is the base class, so will be the last to be called in the cascade. + keeps%nbody = size(keeps%id(:)) + end associate + + return + end subroutine swiftest_util_fill_body + + + module subroutine swiftest_util_fill_pl(self, inserts, lfill_list) + !! author: David A. Minton + !! + !! Insert new Swiftest massive body structure into an old one. + !! This is the inverse of a spill operation. + implicit none + ! Arguments + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_body), intent(in) :: inserts !! Swiftest body object to be inserted + logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps + + associate(keeps => self) + + select type (inserts) ! The standard requires us to select the type of both arguments in order to access all the components + class is (swiftest_pl) + !> Fill components specific to the massive body class + call util_fill(keeps%mass, inserts%mass, lfill_list) + call util_fill(keeps%Gmass, inserts%Gmass, lfill_list) + call util_fill(keeps%rhill, inserts%rhill, lfill_list) + call util_fill(keeps%renc, inserts%renc, lfill_list) + call util_fill(keeps%radius, inserts%radius, lfill_list) + call util_fill(keeps%density, inserts%density, lfill_list) + call util_fill(keeps%rbeg, inserts%rbeg, lfill_list) + call util_fill(keeps%rend, inserts%rend, lfill_list) + call util_fill(keeps%vbeg, inserts%vbeg, lfill_list) + call util_fill(keeps%Ip, inserts%Ip, lfill_list) + call util_fill(keeps%rot, inserts%rot, lfill_list) + call util_fill(keeps%k2, inserts%k2, lfill_list) + call util_fill(keeps%Q, inserts%Q, lfill_list) + call util_fill(keeps%tlag, inserts%tlag, lfill_list) + call util_fill(keeps%kin, inserts%kin, lfill_list) + call util_fill(keeps%nplenc, inserts%nplenc, lfill_list) + call util_fill(keeps%ntpenc, inserts%ntpenc, lfill_list) + + if (allocated(keeps%k_plpl)) deallocate(keeps%k_plpl) + + call util_fill_body(keeps, inserts, lfill_list) + class default + write(*,*) 'Error! fill method called for incompatible return type on swiftest_pl' + end select + end associate + + return + end subroutine swiftest_util_fill_pl + + + module subroutine swiftest_util_fill_tp(self, inserts, lfill_list) + !! author: David A. Minton + !! + !! Insert new Swiftest test particle structure into an old one. + !! This is the inverse of a fill operation. + implicit none + ! Arguments + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + class(swiftest_body), intent(in) :: inserts !! Swiftest body object to be inserted + logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps + + associate(keeps => self) + select type(inserts) + class is (swiftest_tp) + !> Spill components specific to the test particle class + call util_fill(keeps%nplenc, inserts%nplenc, lfill_list) + + call util_fill_body(keeps, inserts, lfill_list) + class default + write(*,*) 'Error! fill method called for incompatible return type on swiftest_tp' + end select + end associate + + return + end subroutine swiftest_util_fill_tp + + + module subroutine swiftest_util_final_storage(self) + !! author: David A. Minton + !! + !! Finalizer for the storage data type + implicit none + ! Arguments + type(swiftest_storage(*)) :: self + ! Internals + integer(I4B) :: i + + do i = 1, self%nframes + if (allocated(self%frame(i)%item)) deallocate(self%frame(i)%item) + end do + + return + end subroutine swiftest_util_final_storage + + + module subroutine swiftest_util_final_system(self) + !! author: David A. Minton + !! + !! Finalize the swiftest nbody system object - deallocates all allocatables + implicit none + ! Argument + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object + + if (allocated(self%cb)) deallocate(self%cb) + if (allocated(self%pl)) deallocate(self%pl) + if (allocated(self%tp)) deallocate(self%tp) + if (allocated(self%tp_discards)) deallocate(self%tp_discards) + if (allocated(self%pl_discards)) deallocate(self%pl_discards) + + return + end subroutine swiftest_util_final_system + + + pure module subroutine swiftest_util_flatten_eucl_ij_to_k(n, i, j, k) + !! author: Jacob R. Elliott and David A. Minton + !! + !! Turns i,j indices into k index for use in the Euclidean distance matrix for pl-pl interactions. + !! + !! Reference: + !! + !! Mélodie Angeletti, Jean-Marie Bonny, Jonas Koko. Parallel Euclidean distance matrix computation on big datasets *. + !! 2019. hal-0204751 + implicit none + ! Arguments + integer(I4B), intent(in) :: n !! Number of bodies + integer(I4B), intent(in) :: i !! Index of the ith body + integer(I4B), intent(in) :: j !! Index of the jth body + integer(I8B), intent(out) :: k !! Index of the flattened matrix + ! Internals + integer(I8B) :: i8, j8, n8 + + i8 = int(i, kind=I8B) + j8 = int(j, kind=I8B) + n8 = int(n, kind=I8B) + k = (i8 - 1_I8B) * n8 - i8 * (i8 - 1_I8B) / 2_I8B + (j8 - i8) + + return + end subroutine swiftest_util_flatten_eucl_ij_to_k + + + pure module subroutine swiftest_util_flatten_eucl_k_to_ij(n, k, i, j) + !! author: Jacob R. Elliott and David A. Minton + !! + !! Turns k index into i,j indices for use in the Euclidean distance matrix for pl-pl interactions. + !! + !! Reference: + !! + !! Mélodie Angeletti, Jean-Marie Bonny, Jonas Koko. Parallel Euclidean distance matrix computation on big datasets *. + !! 2019. hal-0204751 + implicit none + ! Arguments + integer(I4B), intent(in) :: n !! Number of bodies + integer(I8B), intent(in) :: k !! Index of the flattened matrix + integer(I4B), intent(out) :: i !! Index of the ith body + integer(I4B), intent(out) :: j !! Index of the jth body + ! Internals + integer(I8B) :: kp, p, i8, j8, n8 + + n8 = int(n, kind=I8B) + + kp = n8 * (n8 - 1_I8B) / 2_I8B - k + p = floor((sqrt(1._DP + 8_I8B * kp) - 1_I8B) / 2_I8B) + i8 = n8 - 1_I8B - p + j8 = k - (n8 - 1_I8B) * (n8 - 2_I8B) / 2_I8B + p * (p + 1_I8B) / 2_I8B + 1_I8B + + i = int(i8, kind=I4B) + j = int(j8, kind=I4B) + + return + end subroutine swiftest_util_flatten_eucl_k_to_ij + + + module subroutine swiftest_util_flatten_eucl_plpl(self, param) + !! author: Jacob R. Elliott and David A. Minton + !! + !! Turns i,j indices into k index for use in the Euclidean distance matrix for pl-pl interactions for a Swiftest massive body object + !! + !! Reference: + !! + !! Mélodie Angeletti, Jean-Marie Bonny, Jonas Koko. Parallel Euclidean distance matrix computation on big datasets *. + !! 2019. hal-0204751 + implicit none + ! Arguments + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + ! Internals + integer(I4B) :: i, j, err + integer(I8B) :: k, npl + + npl = int(self%nbody, kind=I8B) + associate(nplpl => self%nplpl) + nplpl = npl * (npl - 1_I8B) / 2_I8B ! number of entries in a strict lower triangle, npl x npl + if (param%lflatten_interactions) then + 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), stat=err) + if (err /=0) then ! An error occurred trying to allocate this big array. This probably means it's too big to fit in memory, and so we will force the run back into triangular mode + param%lflatten_interactions = .false. + else + do concurrent (i=1:npl, j=1:npl, j>i) + call util_flatten_eucl_ij_to_k(self%nbody, i, j, k) + self%k_plpl(1, k) = i + self%k_plpl(2, k) = j + end do + end if + end if + end associate + + return + end subroutine swiftest_util_flatten_eucl_plpl + + + module subroutine swiftest_util_flatten_eucl_pltp(self, pl, param) + !! author: Jacob R. Elliott and David A. Minton + !! + !! Turns i,j indices into k index for use in the Euclidean distance matrix for pl-tp interactions + !! + !! Reference: + !! + !! Mélodie Angeletti, Jean-Marie Bonny, Jonas Koko. Parallel Euclidean distance matrix computation on big datasets *. + !! 2019. hal-0204751 + implicit none + ! Arguments + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + class(swiftest_pl), intent(in) :: pl !! Swiftest massive body object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + ! Internals + integer(I8B) :: i, j, counter, npl, ntp + + ntp = int(self%nbody, kind=I8B) + npl = int(pl%nbody, kind=I8B) + associate(npltp => self%npltp) + npltp = npl * ntp + if (allocated(self%k_pltp)) deallocate(self%k_pltp) ! Reset the index array if it's been set previously + allocate(self%k_pltp(2, npltp)) + do i = 1_I8B, npl + counter = (i - 1_I8B) * npl + 1_I8B + do j = 1_I8B, ntp + self%k_pltp(1, counter) = i + self%k_pltp(2, counter) = j + counter = counter + 1_I8B + end do + end do + end associate + + return + end subroutine swiftest_util_flatten_eucl_pltp + + + module subroutine swiftest_util_get_energy_momentum_system(self, param) + !! author: David A. Minton + !! + !! Compute total system angular momentum vector and kinetic, potential and total system energy + !! + !! Adapted from David E. Kaufmann Swifter routine symba_energy_eucl.f90 + !! + !! Adapted from Martin Duncan's Swift routine anal_energy.f + implicit none + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object + class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters + ! Internals + integer(I4B) :: i + real(DP) :: kecb, kespincb + real(DP), dimension(self%pl%nbody) :: kepl, kespinpl + real(DP), dimension(self%pl%nbody) :: Lplorbitx, Lplorbity, Lplorbitz + real(DP), dimension(self%pl%nbody) :: Lplspinx, Lplspiny, Lplspinz + real(DP), dimension(NDIM) :: Lcborbit, Lcbspin + real(DP) :: hx, hy, hz + + associate(system => self, pl => self%pl, npl => self%pl%nbody, cb => self%cb) + system%Lorbit(:) = 0.0_DP + system%Lspin(:) = 0.0_DP + system%Ltot(:) = 0.0_DP + system%ke_orbit = 0.0_DP + system%ke_spin = 0.0_DP + + kepl(:) = 0.0_DP + Lplorbitx(:) = 0.0_DP + Lplorbity(:) = 0.0_DP + Lplorbitz(:) = 0.0_DP + Lplspinx(:) = 0.0_DP + Lplspiny(:) = 0.0_DP + Lplspinz(:) = 0.0_DP + + pl%lmask(1:npl) = pl%status(1:npl) /= INACTIVE + + system%GMtot = cb%Gmass + sum(pl%Gmass(1:npl), pl%lmask(1:npl)) + kecb = cb%mass * dot_product(cb%vb(:), cb%vb(:)) + Lcborbit(:) = cb%mass * (cb%rb(:) .cross. cb%vb(:)) + + do concurrent (i = 1:npl, pl%lmask(i)) + hx = pl%rb(2,i) * pl%vb(3,i) - pl%rb(3,i) * pl%vb(2,i) + hy = pl%rb(3,i) * pl%vb(1,i) - pl%rb(1,i) * pl%vb(3,i) + hz = pl%rb(1,i) * pl%vb(2,i) - pl%rb(2,i) * pl%vb(1,i) + + ! Angular momentum from orbit + Lplorbitx(i) = pl%mass(i) * hx + Lplorbity(i) = pl%mass(i) * hy + Lplorbitz(i) = pl%mass(i) * hz + + ! Kinetic energy from orbit + kepl(i) = pl%mass(i) * dot_product(pl%vb(:,i), pl%vb(:,i)) + end do + + if (param%lrotation) then + kespincb = cb%mass * cb%Ip(3) * cb%radius**2 * dot_product(cb%rot(:), cb%rot(:)) + + ! For simplicity, we always assume that the rotation pole is the 3rd principal axis + Lcbspin(:) = cb%Ip(3) * cb%mass * cb%radius**2 * cb%rot(:) + + do concurrent (i = 1:npl, pl%lmask(i)) + ! Currently we assume that the rotation pole is the 3rd principal axis + ! Angular momentum from spin + Lplspinx(i) = pl%mass(i) * pl%Ip(3,i) * pl%radius(i)**2 * pl%rot(1,i) + Lplspiny(i) = pl%mass(i) * pl%Ip(3,i) * pl%radius(i)**2 * pl%rot(2,i) + Lplspinz(i) = pl%mass(i) * pl%Ip(3,i) * pl%radius(i)**2 * pl%rot(3,i) + + ! Kinetic energy from spin + kespinpl(i) = pl%mass(i) * pl%Ip(3,i) * pl%radius(i)**2 * dot_product(pl%rot(:,i), pl%rot(:,i)) + end do + else + kespincb = 0.0_DP + kespinpl(:) = 0.0_DP + end if + + if (param%lflatten_interactions) then + call util_get_energy_potential_flat(npl, pl%nplpl, pl%k_plpl, pl%lmask, cb%Gmass, pl%Gmass, pl%mass, pl%rb, system%pe) + else + call util_get_energy_potential_triangular(npl, pl%lmask, cb%Gmass, pl%Gmass, pl%mass, pl%rb, system%pe) + end if + + ! Potential energy from the oblateness term + if (param%loblatecb) then + call system%obl_pot() + system%pe = system%pe + system%oblpot + end if + + system%ke_orbit = 0.5_DP * (kecb + sum(kepl(1:npl), pl%lmask(1:npl))) + if (param%lrotation) system%ke_spin = 0.5_DP * (kespincb + sum(kespinpl(1:npl), pl%lmask(1:npl))) + + system%Lorbit(1) = Lcborbit(1) + sum(Lplorbitx(1:npl), pl%lmask(1:npl)) + system%Lorbit(2) = Lcborbit(2) + sum(Lplorbity(1:npl), pl%lmask(1:npl)) + system%Lorbit(3) = Lcborbit(3) + sum(Lplorbitz(1:npl), pl%lmask(1:npl)) + + if (param%lrotation) then + system%Lspin(1) = Lcbspin(1) + sum(Lplspinx(1:npl), pl%lmask(1:npl)) + system%Lspin(2) = Lcbspin(2) + sum(Lplspiny(1:npl), pl%lmask(1:npl)) + system%Lspin(3) = Lcbspin(3) + sum(Lplspinz(1:npl), pl%lmask(1:npl)) + end if + + system%te = system%ke_orbit + system%ke_spin + system%pe + system%Ltot(:) = system%Lorbit(:) + system%Lspin(:) + end associate + + return + end subroutine swiftest_util_get_energy_momentum_system + + + subroutine swiftest_util_get_energy_potential_flat(npl, nplpl, k_plpl, lmask, GMcb, Gmass, mass, rb, pe) + !! author: David A. Minton + !! + !! Compute total system potential energy + implicit none + ! Arguments + integer(I4B), intent(in) :: npl + integer(I8B), intent(in) :: nplpl + integer(I4B), dimension(:,:), intent(in) :: k_plpl + logical, dimension(:), intent(in) :: lmask + real(DP), intent(in) :: GMcb + real(DP), dimension(:), intent(in) :: Gmass + real(DP), dimension(:), intent(in) :: mass + real(DP), dimension(:,:), intent(in) :: rb + real(DP), intent(out) :: pe + ! Internals + integer(I4B) :: i, j + integer(I8B) :: k + real(DP), dimension(npl) :: pecb + real(DP), dimension(nplpl) :: pepl + logical, dimension(nplpl) :: lstatpl + + ! Do the central body potential energy component first + where(.not. lmask(1:npl)) + pecb(1:npl) = 0.0_DP + end where + + do concurrent(i = 1:npl, lmask(i)) + pecb(i) = -GMcb * mass(i) / norm2(rb(:,i)) + end do + + !$omp parallel do default(private) schedule(static)& + !$omp shared(k_plpl, rb, mass, Gmass, pepl, lstatpl, lmask) & + !$omp firstprivate(nplpl) + do k = 1, nplpl + i = k_plpl(1,k) + j = k_plpl(2,k) + lstatpl(k) = (lmask(i) .and. lmask(j)) + if (lstatpl(k)) then + pepl(k) = -(Gmass(i) * mass(j)) / norm2(rb(:, i) - rb(:, j)) + else + pepl(k) = 0.0_DP + end if + end do + !$omp end parallel do + + pe = sum(pepl(:), lstatpl(:)) + sum(pecb(1:npl), lmask(1:npl)) + + return + end subroutine swiftest_util_get_energy_potential_flat + + + subroutine swiftest_util_get_energy_potential_triangular(npl, lmask, GMcb, Gmass, mass, rb, pe) + !! author: David A. Minton + !! + !! Compute total system potential energy + implicit none + ! Arguments + integer(I4B), intent(in) :: npl + logical, dimension(:), intent(in) :: lmask + real(DP), intent(in) :: GMcb + real(DP), dimension(:), intent(in) :: Gmass + real(DP), dimension(:), intent(in) :: mass + real(DP), dimension(:,:), intent(in) :: rb + real(DP), intent(out) :: pe + ! Internals + integer(I4B) :: i, j + real(DP), dimension(npl) :: pecb, pepl + + ! Do the central body potential energy component first + where(.not. lmask(1:npl)) + pecb(1:npl) = 0.0_DP + end where + + do concurrent(i = 1:npl, lmask(i)) + pecb(i) = -GMcb * mass(i) / norm2(rb(:,i)) + end do + + pe = 0.0_DP + !$omp parallel do default(private) schedule(static)& + !$omp shared(lmask, Gmass, mass, rb) & + !$omp firstprivate(npl) & + !$omp reduction(+:pe) + do i = 1, npl + if (lmask(i)) then + do concurrent(j = i+1:npl, lmask(i) .and. lmask(j)) + pepl(j) = - (Gmass(i) * mass(j)) / norm2(rb(:, i) - rb(:, j)) + end do + pe = pe + sum(pepl(i+1:npl), lmask(i+1:npl)) + end if + end do + !$omp end parallel do + pe = pe + sum(pecb(1:npl), lmask(1:npl)) + + return + end subroutine swiftest_util_get_energy_potential_triangular + + + module subroutine swiftest_util_index_array(ind_arr, n) + !! author: David A. Minton + !! + !! Creates or resizes an index array of size n where ind_arr = [1, 2, ... n]. + !! This subroutine swiftest_assumes that if ind_arr is already allocated, it is a pre-existing index array of a different size. + implicit none + ! Arguments + integer(I4B), dimension(:), allocatable, intent(inout) :: ind_arr !! Index array. Input is a pre-existing index array where n /= size(ind_arr). Output is a new index array ind_arr = [1, 2, ... n] + integer(I4B), intent(in) :: n !! The new size of the index array + ! Internals + integer(I4B) :: nold, i + integer(I4B), dimension(:), allocatable :: itmp + + if (allocated(ind_arr)) then + nold = size(ind_arr) + if (nold == n) return ! Nothing to do, so go home + else + nold = 0 + end if + + allocate(itmp(n)) + if (n >= nold) then + if (nold > 0) itmp(1:nold) = ind_arr(1:nold) + itmp(nold+1:n) = [(i, i = nold + 1, n)] + call move_alloc(itmp, ind_arr) + else + itmp(1:n) = ind_arr(1:n) + call move_alloc(itmp, ind_arr) + end if + + return + end subroutine swiftest_util_index_array + + + module subroutine swiftest_util_get_idvalues_system(self, idvals) + !! author: David A. Minton + !! + !! Returns an array of all id values saved in this snapshot + implicit none + ! Arguments + class(swiftest_nbody_system), intent(in) :: self !! Encounter snapshot object + integer(I4B), dimension(:), allocatable, intent(out) :: idvals !! Array of all id values saved in this snapshot + ! Internals + integer(I4B) :: npl, ntp + + if (allocated(self%pl)) then + npl = self%pl%nbody + else + npl = 0 + end if + if (allocated(self%tp)) then + ntp = self%tp%nbody + else + ntp = 0 + end if + + allocate(idvals(1 + npl+ntp)) + + idvals(1) = self%cb%id + if (npl > 0) idvals(2:npl+1) = self%pl%id(:) + if (ntp > 0) idvals(npl+2:npl+ntp+1) = self%tp%id(:) + + return + + end subroutine swiftest_util_get_idvalues_system + + + module subroutine swiftest_util_get_vals_storage(self, idvals, tvals) + !! author: David A. Minton + !! + !! Gets the id values in a storage object, regardless of whether it is encounter of collision + ! Argument + class(swiftest_storage(*)), intent(in) :: self !! Swiftest storage object + integer(I4B), dimension(:), allocatable, intent(out) :: idvals !! Array of all id values in all snapshots + real(DP), dimension(:), allocatable, intent(out) :: tvals !! Array of all time values in all snapshots + ! Internals + integer(I4B) :: i, n, nlo, nhi, ntotal + integer(I4B), dimension(:), allocatable :: itmp + + associate(storage => self, nsnaps => self%iframe) + + allocate(tvals(nsnaps)) + tvals(:) = 0.0_DP + + ! First pass to get total number of ids + ntotal = 0 + do i = 1, nsnaps + if (allocated(storage%frame(i)%item)) then + select type(snapshot => storage%frame(i)%item) + class is (swiftest_nbody_system) + tvals(i) = snapshot%t + call snapshot%get_idvals(itmp) + if (allocated(itmp)) then + n = size(itmp) + ntotal = ntotal + n + end if + end select + end if + end do + + allocate(idvals(ntotal)) + nlo = 1 + ! Second pass to store all ids get all of the ids stored + do i = 1, nsnaps + if (allocated(storage%frame(i)%item)) then + select type(snapshot => storage%frame(i)%item) + class is (swiftest_nbody_system) + tvals(i) = snapshot%t + call snapshot%get_idvals(itmp) + if (allocated(itmp)) then + n = size(itmp) + nhi = nlo + n - 1 + idvals(nlo:nhi) = itmp(1:n) + nlo = nhi + 1 + end if + end select + end if + end do + + end associate + return + end subroutine swiftest_util_get_vals_storage + + + module subroutine swiftest_util_index_map_storage(self) + !! author: David A. Minton + !! + !! Maps body id values to storage index values so we don't have to use unlimited dimensions for id + implicit none + ! Arguments + class(swiftest_storage(*)), intent(inout) :: self !! Swiftest storage object + ! Internals + integer(I4B), dimension(:), allocatable :: idvals + real(DP), dimension(:), allocatable :: tvals + + call util_get_vals_storage(self, idvals, tvals) + + call util_unique(idvals,self%idvals,self%idmap) + self%nid = size(self%idvals) + + call util_unique(tvals,self%tvals,self%tmap) + self%nt = size(self%tvals) + + return + end subroutine swiftest_util_index_map_storage + + module subroutine swiftest_util_minimize_bfgs(f, N, x0, eps, maxloop, lerr, x1) + !! author: David A. Minton + !! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! This function implements the Broyden-Fletcher-Goldfarb-Shanno method to determine the minimum of a function of N variables. + !! It recieves as input: + !! f%eval(x) : lambda function object containing the objective function as the eval metho + !! N : Number of variables of function f + !! x0 : Initial starting value of x + !! eps : Accuracy of 1 - dimensional minimization at each step + !! maxloop : Maximum number of loops to attempt to find a solution + !! The outputs include + !! lerr : Returns .true. if it could not find the minimum + !! Returns + !! x1 : Final minimum (all 0 if none found) + !! 0 = No miniumum found + !! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + use, intrinsic :: ieee_exceptions + implicit none + ! Arguments + integer(I4B), intent(in) :: N + class(lambda_obj), intent(inout) :: f + real(DP), dimension(:), intent(in) :: x0 + real(DP), intent(in) :: eps + integer(I4B), intent(in) :: maxloop + logical, intent(out) :: lerr + ! Result + real(DP), dimension(:), intent(out), allocatable :: x1 + ! Internals + integer(I4B) :: i, j, k, l, conv + real(DP), parameter :: graddelta = 1e-4_DP !! Delta x for gradient calculations + real(DP), dimension(N) :: S !! Direction vectors + real(DP), dimension(N,N) :: H !! Approximated inverse Hessian matrix + real(DP), dimension(N) :: grad1 !! gradient of f + real(DP), dimension(N) :: grad0 !! old value of gradient + real(DP) :: astar !! 1D minimized value + real(DP), dimension(N) :: y, P + real(DP), dimension(N,N) :: PP, PyH, HyP + real(DP), save :: yHy, Py + type(ieee_status_type) :: original_fpe_status + logical, dimension(:), allocatable :: fpe_flag + + call ieee_get_status(original_fpe_status) ! Save the original floating point exception status + call ieee_set_flag(ieee_all, .false.) ! Set all flags to quiet + allocate(fpe_flag(size(ieee_usual))) + + lerr = .false. + allocate(x1, source=x0) + ! Initialize approximate Hessian with the identity matrix (i.e. begin with method of steepest descent) + ! Get initial gradient and initialize arrays for updated values of gradient and x + H(:,:) = reshape([((0._DP, i=1, j-1), 1._DP, (0._DP, i=j+1, N), j=1, N)], [N,N]) + grad0 = gradf(f, N, x0(:), graddelta, lerr) + if (lerr) then + call ieee_set_status(original_fpe_status) + return + end if + grad1(:) = grad0(:) + do i = 1, maxloop + !check for convergence + conv = count(abs(grad1(:)) > eps) + if (conv == 0) exit + S(:) = -matmul(H(:,:), grad1(:)) + astar = minimize1D(f, x1, S, N, graddelta, lerr) + if (lerr) exit + ! Get new x values + P(:) = astar * S(:) + x1(:) = x1(:) + P(:) + ! Calculate new gradient + grad0(:) = grad1(:) + grad1 = gradf(f, N, x1, graddelta, lerr) + y(:) = grad1(:) - grad0(:) + Py = sum(P(:) * y(:)) + ! set up factors for H matrix update + yHy = 0._DP + !$omp do simd schedule(static)& + !$omp firstprivate(N, y, H) & + !$omp reduction(+:yHy) + do k = 1, N + do j = 1, N + yHy = yHy + y(j) * H(j,k) * y(k) + end do + end do + !$omp end do simd + ! prevent divide by zero (convergence) + if (abs(Py) < tiny(Py)) exit + ! set up update + PyH(:,:) = 0._DP + HyP(:,:) = 0._DP + !$omp parallel do default(private) schedule(static)& + !$omp shared(N, PP, P, y, H) & + !$omp reduction(+:PyH, HyP) + do k = 1, N + do j = 1, N + PP(j, k) = P(j) * P(k) + do l = 1, N + PyH(j, k) = PyH(j, k) + P(j) * y(l) * H(l,k) + HyP(j, k) = HyP(j, k) + P(k) * y(l) * H(j,l) + end do + end do + end do + !$omp end parallel do + ! update H matrix + H(:,:) = H(:,:) + ((1._DP - yHy / Py) * PP(:,:) - PyH(:,:) - HyP(:,:)) / Py + ! Normalize to prevent it from blowing up if it takes many iterations to find a solution + H(:,:) = H(:,:) / norm2(H(:,:)) + ! Stop everything if there are any exceptions to allow the routine to fail gracefully + call ieee_get_flag(ieee_usual, fpe_flag) + if (any(fpe_flag)) exit + if (i == maxloop) then + lerr = .true. + end if + end do + call ieee_get_flag(ieee_usual, fpe_flag) + lerr = lerr .or. any(fpe_flag) + call ieee_set_status(original_fpe_status) + + return + + contains + + function gradf(f, N, x1, dx, lerr) result(grad) + !! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! Purpose: Estimates the gradient of a function using a central difference + !! approximation + !! Inputs: + !! f%eval(x) : lambda function object containing the objective function as the eval metho + !! N : number of variables N + !! x1 : x value array + !! dx : step size to use when calculating derivatives + !! Outputs: + !! lerr : .true. if an error occurred. Otherwise returns .false. + !! Returns + !! grad : N sized array containing estimated gradient of f at x1 + !! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none + ! Arguments + integer(I4B), intent(in) :: N + class(lambda_obj), intent(inout) :: f + real(DP), dimension(:), intent(in) :: x1 + real(DP), intent(in) :: dx + logical, intent(out) :: lerr + ! Result + real(DP), dimension(N) :: grad + ! Internals + integer(I4B) :: i, j + real(DP), dimension(N) :: xp, xm + real(DP) :: fp, fm + logical :: lerrp, lerrm + + do i = 1, N + do j = 1, N + if (j == i) then + xp(j) = x1(j) + dx + xm(j) = x1(j) - dx + else + xp(j) = x1(j) + xm(j) = x1(j) + end if + end do + select type (f) + class is (lambda_obj_err) + fp = f%eval(xp) + lerrp = f%lerr + fm = f%eval(xm) + lerrm = f%lerr + lerr = lerrp .or. lerrm + class is (lambda_obj) + fp = f%eval(xp) + fm = f%eval(xm) + lerr = .false. + end select + grad(i) = (fp - fm) / (2 * dx) + if (lerr) return + end do + return + end function gradf + + + function minimize1D(f, x0, S, N, eps, lerr) result(astar) + !! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! This program find the minimum of a function of N variables in a single direction + !! S using in sequence: + !! 1. A Bracketing method + !! 2. The golden section method + !! 3. A quadratic polynomial fit + !! Inputs + !! f%eval(x) : lambda function object containing the objective function as the eval metho + !! x0 : Array of size N of initial x values + !! S : Array of size N that determines the direction of minimization + !! N : Number of variables of function f + !! eps : Accuracy of 1 - dimensional minimization at each step + !! Output + !! lerr : .true. if an error occurred. Otherwise returns .false. + !! Returns + !! astar : Final minimum along direction S + !! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none + ! Arguments + integer(I4B), intent(in) :: N + class(lambda_obj), intent(inout) :: f + real(DP), dimension(:), intent(in) :: x0, S + real(DP), intent(in) :: eps + logical, intent(out) :: lerr + ! Result + real(DP) :: astar + ! Internals + integer(I4B) :: num = 0 + real(DP), parameter :: step = 0.7_DP !! Bracketing method step size + real(DP), parameter :: gam = 1.2_DP !! Bracketing method expansion parameter + real(DP), parameter :: greduce = 0.2_DP !! Golden section method reduction factor + real(DP), parameter :: greduce2 = 0.1_DP ! Secondary golden section method reduction factor + real(DP) :: alo, ahi !! High and low values for 1 - D minimization routines + real(DP), parameter :: a0 = epsilon(1.0_DP) !! Initial guess of alpha + + alo = a0 + call bracket(f, x0, S, N, gam, step, alo, ahi, lerr) + if (lerr) then + !write(*,*) "BFGS bracketing step failed!" + !write(*,*) "alo: ",alo, "ahi: ", ahi + return + end if + if (abs(alo - ahi) < eps) then + astar = alo + lerr = .false. + return + end if + call golden(f, x0, S, N, greduce, alo, ahi, lerr) + if (lerr) then + !write(*,*) "BFGS golden section step failed!" + return + end if + if (abs(alo - ahi) < eps) then + astar = alo + lerr = .false. + return + end if + call quadfit(f, x0, S, N, eps, alo, ahi, lerr) + if (lerr) then + !write(*,*) "BFGS quadfit failed!" + return + end if + if (abs(alo - ahi) < eps) then + astar = alo + lerr = .false. + return + end if + ! Quadratic fit method won't converge, so finish off with another golden section + call golden(f, x0, S, N, greduce2, alo, ahi, lerr) + if (.not. lerr) astar = (alo + ahi) / 2.0_DP + return + end function minimize1D + + + function n2one(f, x0, S, N, a, lerr) result(fnew) + implicit none + ! Arguments + integer(I4B), intent(in) :: N + class(lambda_obj), intent(inout) :: f + real(DP), dimension(:), intent(in) :: x0, S + real(DP), intent(in) :: a + logical, intent(out) :: lerr + + ! Return + real(DP) :: fnew + ! Internals + real(DP), dimension(N) :: xnew + integer(I4B) :: i + + xnew(:) = x0(:) + a * S(:) + fnew = f%eval(xnew(:)) + select type(f) + class is (lambda_obj_err) + lerr = f%lerr + class is (lambda_obj) + lerr = .false. + end select + return + end function n2one + + ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + subroutine swiftest_bracket(f, x0, S, N, gam, step, lo, hi, lerr) + ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! This subroutine swiftest_brackets the minimum. It recieves as input: + !! f%eval(x) : lambda function object containing the objective function as the eval metho + !! x0 : Array of size N of initial x values + !! S : Array of size N that determines the direction of minimization + !! gam : expansion parameter + !! step : step size + !! lo : initial guess of lo bracket value + !! The outputs include + !! lo : lo bracket + !! hi : hi bracket + !! lerr : .true. if an error occurred. Otherwise returns .false. + !! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none + ! Arguments + integer(I4B), intent(in) :: N + class(lambda_obj), intent(inout) :: f + real(DP), dimension(:), intent(in) :: x0, S + real(DP), intent(in) :: gam, step + real(DP), intent(inout) :: lo + real(DP), intent(out) :: hi + logical, intent(out) :: lerr + ! Internals + real(DP) :: a0, a1, a2, atmp, da + real(DP) :: f0, f1, f2 + integer(I4B) :: i, j + integer(I4B), parameter :: MAXLOOP = 100 ! maximum number of loops before method is determined to have failed + real(DP), parameter :: eps = epsilon(lo) ! small number precision to test floating point equality + + ! set up initial bracket points + a0 = lo + da = step + a1 = a0 + da + a2 = a0 + 2 * da + f0 = n2one(f, x0, S, N, a0, lerr) + if (lerr) return + f1 = n2one(f, x0, S, N, a1, lerr) + if (lerr) return + f2 = n2one(f, x0, S, N, a2, lerr) + if (lerr) return + ! loop over bracket method until either min is bracketed method fails + do i = 1, MAXLOOP + if ((f0 > f1) .and. (f1 < f2)) then ! Minimum was found + lo = a0 + hi = a2 + return + else if ((f0 >= f1) .and. (f1 > f2)) then ! Function appears to decrease + da = da * gam + atmp = a2 + da + a0 = a1 + a1 = a2 + a2 = atmp + f0 = f1 + f1 = f2 + f2 = n2one(f, x0, S, N, a2, lerr) + else if ((f0 < f1) .and. (f1 <= f2)) then ! Function appears to increase + da = da * gam + atmp = a0 - da + a2 = a1 + a1 = a0 + a0 = atmp + f2 = f1 + f0 = n2one(f, x0, S, N, a0, lerr) + else if ((f0 < f1) .and. (f1 > f2)) then ! We are at a peak. Pick the direction that descends the fastest + da = da * gam + if (f2 > f0) then ! LHS is lower than RHS + atmp = a2 + da + a0 = a1 + a1 = a2 + a2 = atmp + f0 = f1 + f1 = f2 + f2 = n2one(f, x0, S, N, a2, lerr) + else ! RHS is lower than LHS + atmp = a0 - da + a2 = a1 + a1 = a0 + a0 = atmp + f2 = f1 + f1 = f2 + f0 = n2one(f, x0, S, N, a0, lerr) + end if + else if ((f0 > f1) .and. (abs(f2 - f1) <= eps)) then ! Decrasging but RHS equal + da = da * gam + atmp = a2 + da + a2 = atmp + f2 = n2one(f, x0, S, N, a2, lerr) + else if ((abs(f0 - f1) < eps) .and. (f1 < f2)) then ! Increasing but LHS equal + da = da * gam + atmp = a0 - da + a0 = atmp + f0 = n2one(f, x0, S, N, a0, lerr) + else ! all values equal. Expand in either direction and try again + a0 = a0 - da + a2 = a2 + da + f0 = n2one(f, x0, S, N, a0, lerr) + if (lerr) exit ! An error occurred while evaluating the function + f2 = n2one(f, x0, S, N, a2, lerr) + end if + if (lerr) exit ! An error occurred while evaluating the function + end do + lerr = .true. + return ! no minimum found + end subroutine swiftest_bracket + + ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + subroutine swiftest_golden(f, x0, S, N, eps, lo, hi, lerr) + ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! This function uses the golden section method to reduce the starting interval lo, hi by some amount sigma. + !! It recieves as input: + !! f%eval(x) : lambda function object containing the objective function as the eval metho + !! x0 : Array of size N of initial x values + !! S : Array of size N that determines the direction of minimization + !! gam : expansion parameter + !! eps : reduction interval in range (0 < sigma < 1) such that: + !! hi(new) - lo(new) = eps * (hi(old) - lo(old)) + !! lo : initial guess of lo bracket value + !! The outputs include + !! lo : lo bracket + !! hi : hi bracket + !! lerr : .true. if an error occurred. Otherwise returns .false. + !! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none + ! Arguments + integer(I4B), intent(in) :: N + class(lambda_obj), intent(inout) :: f + real(DP), dimension(:), intent(in) :: x0, S + real(DP), intent(in) :: eps + real(DP), intent(inout) :: lo + real(DP), intent(out) :: hi + logical, intent(out) :: lerr + ! Internals + real(DP), parameter :: tau = 0.5_DP * (sqrt(5.0_DP) - 1.0_DP) ! Golden section constant + integer(I4B), parameter :: MAXLOOP = 40 ! maximum number of loops before method is determined to have failed (unlikely, but could occur if no minimum exists between lo and hi) + real(DP) :: i0 ! Initial interval value + real(DP) :: a1, a2 + real(DP) :: f1, f2 + integer(I4B) :: i, j + + i0 = hi - lo + a1 = hi - tau * i0 + a2 = lo + tau * i0 + f1 = n2one(f, x0, S, N, a1, lerr) + if (lerr) return + f2 = n2one(f, x0, S, N, a2, lerr) + if (lerr) return + do i = 1, MAXLOOP + if (abs((hi - lo) / i0) <= eps) return ! interval reduced to input amount + if (f2 > f1) then + hi = a2 + a2 = a1 + f2 = f1 + a1 = hi - tau * (hi - lo) + f1 = n2one(f, x0, S, N, a1, lerr) + else + lo = a1 + a1 = a2 + f2 = f1 + a2 = hi - (1.0_DP - tau) * (hi - lo) + f2 = n2one(f, x0, S, N, a2, lerr) + end if + if (lerr) exit + end do + lerr = .true. + return ! search took too many iterations - no minimum found + end subroutine swiftest_golden + + ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + subroutine swiftest_quadfit(f, x0, S, N, eps, lo, hi, lerr) + ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + !! This function uses a quadratic polynomial fit to locate the minimum of a function + !! to some accuracy eps. It recieves as input: + !! f%eval(x) : lambda function object containing the objective function as the eval metho + !! lo : low bracket value + !! hi : high bracket value + !! eps : desired accuracy of final minimum location + !! The outputs include + !! lo : final minimum location + !! hi : final minimum location + !! Notes: Uses the ieee_exceptions intrinsic module to allow for graceful failure due to floating point exceptions, which won't terminate the run. + !! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none + ! Arguments + integer(I4B), intent(in) :: N + class(lambda_obj), intent(inout) :: f + real(DP), dimension(:), intent(in) :: x0, S + real(DP), intent(in) :: eps + real(DP), intent(inout) :: lo + real(DP), intent(out) :: hi + logical, intent(out) :: lerr + ! Internals + integer(I4B), parameter :: MAXLOOP = 20 ! maximum number of loops before method is determined to have failed. + real(DP) :: a1, a2, a3, astar ! three points for the polynomial fit and polynomial minimum + real(DP) :: f1, f2, f3, fstar ! three function values for the polynomial and polynomial minimum + real(DP), dimension(3) :: row_1, row_2, row_3, rhs, soln ! matrix for 3 equation solver (gaussian elimination) + real(DP), dimension(3,3) :: lhs + real(DP) :: d1, d2, d3, aold, denom, errval + integer(I4B) :: i + + lerr = .false. + ! Get initial a1, a2, a3 values + a1 = lo + a2 = lo + 0.5_DP * (hi - lo) + a3 = hi + aold = a1 + astar = a2 + f1 = n2one(f, x0, S, N, a1, lerr) + if (lerr) return + f2 = n2one(f, x0, S, N, a2, lerr) + if (lerr) return + f3 = n2one(f, x0, S, N, a3, lerr) + if (lerr) return + do i = 1, MAXLOOP + ! check to see if convergence is reached and exit + errval = abs((astar - aold) / astar) + call ieee_get_flag(ieee_usual, fpe_flag) + if (any(fpe_flag)) then + !write(*,*) 'quadfit fpe' + !write(*,*) 'aold : ',aold + !write(*,*) 'astar: ',astar + lerr = .true. + exit + end if + if (errval < eps) then + lo = astar + hi = astar + exit + end if + ! Set up system for gaussian elimination equation solver + row_1 = [1.0_DP, a1, a1**2] + row_2 = [1.0_DP, a2, a2**2] + row_3 = [1.0_DP, a3, a3**2] + rhs = [f1, f2, f3] + lhs(1, :) = row_1 + lhs(2, :) = row_2 + lhs(3, :) = row_3 + ! Solve system of equations + soln(:) = util_solve_linear_system(lhs, rhs, 3, lerr) + call ieee_set_flag(ieee_all, .false.) ! Set all flags back to quiet + call ieee_set_halting_mode(ieee_divide_by_zero, .false.) + if (lerr) then + !write(*,*) 'quadfit fpe:' + !write(*,*) 'util_solve_linear_system failed' + exit + end if + aold = astar + if (soln(2) == soln(3)) then ! Handles the case where they are both 0. 0/0 is an unhandled exception + astar = -0.5_DP + else + astar = -soln(2) / (2 * soln(3)) + end if + call ieee_get_flag(ieee_usual, fpe_flag) + if (any(fpe_flag)) then + !write(*,*) 'quadfit fpe' + !write(*,*) 'soln(2:3): ',soln(2:3) + !write(*,*) 'a1, a2, a3' + !write(*,*) a1, a2, a3 + !write(*,*) 'f1, f2, f3' + !write(*,*) f1, f2, f3 + lerr = .true. + exit + end if + fstar = n2one(f, x0, S, N, astar, lerr) + if (lerr) exit + ! keep the three closest a values to astar and discard the fourth + d1 = abs(a1 - astar) + d2 = abs(a2 - astar) + d3 = abs(a3 - astar) + + if (d1 > d2) then + if (d1 > d3) then + f1 = fstar + a1 = astar + else if (d3 > d2) then + f3 = fstar + a3 = astar + end if + else + if (d2 > d3) then + f2 = fstar + a2 = astar + else if (d3 > d1) then + f3 = fstar + a3 = astar + end if + end if + end do + if (lerr) return + lo = a1 + hi = a3 + return + end subroutine swiftest_quadfit + + end subroutine swiftest_util_minimize_bfgs + + subroutine swiftest_util_peri(n,m, r, v, atp, q, isperi) + !! author: David A. Minton + !! + !! Helper function that does the pericenter passage computation for any body + !! + !! Adapted from David E. Kaufmann's Swifter routine: symba_peri.f90 + !! Adapted from Hal Levison's Swift routine util_mass_peri.f + implicit none + ! Arguments + integer(I4B), intent(in) :: n !! Number of bodies + real(DP), dimension(:), intent(in) :: m !! Mass term (mu for HELIO coordinates, and Gmtot for BARY) + real(DP), dimension(:,:), intent(in) :: r !! Position vectors (rh for HELIO coordinates, rb for BARY) + real(DP), dimension(:,:), intent(in) :: v !! Position vectors (vh for HELIO coordinates, rb for BARY) + real(DP), dimension(:), intent(out) :: atp !! Semimajor axis + real(DP), dimension(:), intent(out) :: q !! Periapsis + integer(I4B), dimension(:), intent(inout) :: isperi !! Periapsis passage flag + ! Internals + integer(I4B) :: i + real(DP), dimension(n) :: e !! Temporary, just to make use of the xv2aeq subroutine + real(DP) :: vdotr + + do concurrent(i = 1:n) + vdotr = dot_product(r(:,i),v(:,i)) + if (isperi(i) == -1) then + if (vdotr >= 0.0) then + isperi(i) = 0 + call swiftest_orbel_xv2aeq(m(i),r(1,i),r(2,i),r(3,i),v(1,i),v(2,i),v(3,i),atp(i),e(i),q(i)) + end if + else + if (vdotr > 0.0) then + isperi(i) = -1 + else + isperi(i) = 1 + end if + end if + end do + + return + end subroutine swiftest_util_peri + + + module subroutine swiftest_util_peri_body(self, system, param) + !! author: David A. Minton + !! + !! Determine system pericenter passages for bodies + !! + !! Adapted from David E. Kaufmann's Swifter routine: symba_peri.f90 + !! Adapted from Hal Levison's Swift routine util_mass_peri.f + implicit none + ! Arguments + class(swiftest_body), intent(inout) :: self !! SyMBA massive body object + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters + ! Internals + integer(I4B) :: i + + select type(self) + class is (swiftest_pl) + if (self%lfirst) self%isperi(:) = 0 + end select + + if (param%qmin_coord == "HELIO") then + call swiftest_util_peri(self%nbody, self%mu, self%rh, self%vh, self%atp, self%peri, self%isperi) + else + call swiftest_util_peri(self%nbody, [(system%Gmtot,i=1,self%nbody)], self%rb, self%vb, self%atp, self%peri, self%isperi) + end if + + return + end subroutine swiftest_util_peri_body + + + module subroutine swiftest_util_rearray_pl(self, system, param) + !! Author: the Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott + !! + !! Clean up the massive body structures to remove discarded bodies and add new bodies + use symba + implicit none + ! Arguments + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + ! Internals + class(swiftest_pl), allocatable :: tmp !! The discarded body list. + integer(I4B) :: i, k, npl, nadd, nencmin, nenc_old, idnew1, idnew2, idold1, idold2 + logical, dimension(:), allocatable :: lmask, ldump_mask + class(collision_list_plpl), allocatable :: plplenc_old + logical :: lencounter + integer(I4B), dimension(:), allocatable :: levelg_orig_pl, levelm_orig_pl, levelg_orig_tp, levelm_orig_tp + integer(I4B), dimension(:), allocatable :: nplenc_orig_pl, nplenc_orig_tp, ntpenc_orig_pl + + associate(pl => self, pl_adds => system%pl_adds) + + npl = pl%nbody + nadd = pl_adds%nbody + if (npl == 0) return + ! Deallocate any temporary variables + if (allocated(pl%rbeg)) deallocate(pl%rbeg) + if (allocated(pl%rend)) deallocate(pl%rend) + + ! Remove the discards and destroy the list, as the system already tracks pl_discards elsewhere + allocate(lmask(npl)) + lmask(1:npl) = pl%ldiscard(1:npl) + if (count(lmask(:)) > 0) then + allocate(tmp, mold=self) + call pl%spill(tmp, lspill_list=lmask, ldestructive=.true.) + npl = pl%nbody + call tmp%setup(0,param) + deallocate(tmp) + deallocate(lmask) + end if + + ! Store the original plplenc list so we don't remove any of the original encounters + nenc_old = system%plpl_encounter%nenc + if (nenc_old > 0) then + allocate(plplenc_old, source=system%plpl_encounter) + call plplenc_old%copy(system%plpl_encounter) + end if + + ! Add in any new bodies + if (nadd > 0) then + ! Append the adds to the main pl object + call pl%append(pl_adds, lsource_mask=[(.true., i=1, nadd)]) + + allocate(ldump_mask(npl+nadd)) ! This mask is used only to append the original Fortran binary particle.dat file with new bodies. This is ignored for NetCDF output + ldump_mask(1:npl) = .false. + ldump_mask(npl+1:npl+nadd) = pl%status(npl+1:npl+nadd) == NEW_PARTICLE + npl = pl%nbody + else + allocate(ldump_mask(npl)) + ldump_mask(:) = .false. + end if + + ! Reset all of the status flags for this body + pl%status(1:npl) = ACTIVE + do i = 1, npl + call pl%info(i)%set_value(status="ACTIVE") + end do + pl%ldiscard(1:npl) = .false. + pl%lcollision(1:npl) = .false. + pl%lmask(1:npl) = .true. + + pl%lmtiny(1:npl) = pl%Gmass(1:npl) < param%GMTINY + where(pl%lmtiny(1:npl)) + pl%info(1:npl)%particle_type = PL_TINY_TYPE_NAME + elsewhere + pl%info(1:npl)%particle_type = PL_TYPE_NAME + end where + + call pl%write_info(param%system_history%nc, param) + deallocate(ldump_mask) + + ! Reindex the new list of bodies + call pl%sort("mass", ascending=.false.) + call pl%flatten(param) + + ! Reset the kinship trackers + call pl%reset_kinship([(i, i=1, npl)]) + + ! Re-build the zero-level encounter list, being sure to save the original level information for all bodies + allocate(nplenc_orig_pl, source=pl%nplenc) + select type(pl) + class is (symba_pl) + allocate(levelg_orig_pl, source=pl%levelg) + allocate(levelm_orig_pl, source=pl%levelm) + call move_alloc(levelg_orig_pl, pl%levelg) + call move_alloc(levelm_orig_pl, pl%levelm) + end select + lencounter = pl%encounter_check(param, system, param%dt, system%irec) + if (system%tp%nbody > 0) then + allocate(ntpenc_orig_pl, source=pl%ntpenc) + allocate(nplenc_orig_tp, source=tp%nplenc) + select type(tp => system%tp) + class is (symba_tp) + allocate(levelg_orig_tp, source=tp%levelg) + allocate(levelm_orig_tp, source=tp%levelm) + lencounter = tp%encounter_check(param, system, param%dt, system%irec) + call move_alloc(levelg_orig_tp, tp%levelg) + call move_alloc(levelm_orig_tp, tp%levelm) + call move_alloc(nplenc_orig_tp, tp%nplenc) + call move_alloc(ntpenc_orig_pl, pl%ntpenc) + end select + end if + + call move_alloc(nplenc_orig_pl, pl%nplenc) + + ! Re-index the encounter list as the index values may have changed + if (nenc_old > 0) then + nencmin = min(system%plpl_encounter%nenc, plplenc_old%nenc) + system%plpl_encounter%nenc = nencmin + do k = 1, nencmin + idnew1 = system%plpl_encounter%id1(k) + idnew2 = system%plpl_encounter%id2(k) + idold1 = plplenc_old%id1(k) + idold2 = plplenc_old%id2(k) + if ((idnew1 == idold1) .and. (idnew2 == idold2)) then + ! This is an encounter we already know about, so save the old information + system%plpl_encounter%lvdotr(k) = plplenc_old%lvdotr(k) + system%plpl_encounter%lclosest(k) = plplenc_old%lclosest(k) + system%plpl_encounter%status(k) = plplenc_old%status(k) + system%plpl_encounter%r1(:,k) = plplenc_old%r1(:,k) + system%plpl_encounter%r2(:,k) = plplenc_old%r2(:,k) + system%plpl_encounter%v1(:,k) = plplenc_old%v1(:,k) + system%plpl_encounter%v2(:,k) = plplenc_old%v2(:,k) + system%plpl_encounter%tcollision(k) = plplenc_old%tcollision(k) + system%plpl_encounter%level(k) = plplenc_old%level(k) + else if (((idnew1 == idold2) .and. (idnew2 == idold1))) then + ! This is an encounter we already know about, but with the order reversed, so save the old information + system%plpl_encounter%lvdotr(k) = plplenc_old%lvdotr(k) + system%plpl_encounter%lclosest(k) = plplenc_old%lclosest(k) + system%plpl_encounter%status(k) = plplenc_old%status(k) + system%plpl_encounter%r1(:,k) = plplenc_old%r2(:,k) + system%plpl_encounter%r2(:,k) = plplenc_old%r1(:,k) + system%plpl_encounter%v1(:,k) = plplenc_old%v2(:,k) + system%plpl_encounter%v2(:,k) = plplenc_old%v1(:,k) + system%plpl_encounter%tcollision(k) = plplenc_old%tcollision(k) + system%plpl_encounter%level(k) = plplenc_old%level(k) + end if + system%plpl_encounter%index1(k) = findloc(pl%id(1:npl), system%plpl_encounter%id1(k), dim=1) + system%plpl_encounter%index2(k) = findloc(pl%id(1:npl), system%plpl_encounter%id2(k), dim=1) + end do + if (allocated(lmask)) deallocate(lmask) + allocate(lmask(nencmin)) + nenc_old = nencmin + if (any(system%plpl_encounter%index1(1:nencmin) == 0) .or. any(system%plpl_encounter%index2(1:nencmin) == 0)) then + lmask(:) = system%plpl_encounter%index1(1:nencmin) /= 0 .and. system%plpl_encounter%index2(1:nencmin) /= 0 + else + return + end if + nencmin = count(lmask(:)) + system%plpl_encounter%nenc = nencmin + if (nencmin > 0) then + system%plpl_encounter%index1(1:nencmin) = pack(system%plpl_encounter%index1(1:nenc_old), lmask(1:nenc_old)) + system%plpl_encounter%index2(1:nencmin) = pack(system%plpl_encounter%index2(1:nenc_old), lmask(1:nenc_old)) + system%plpl_encounter%id1(1:nencmin) = pack(system%plpl_encounter%id1(1:nenc_old), lmask(1:nenc_old)) + system%plpl_encounter%id2(1:nencmin) = pack(system%plpl_encounter%id2(1:nenc_old), lmask(1:nenc_old)) + system%plpl_encounter%lvdotr(1:nencmin) = pack(system%plpl_encounter%lvdotr(1:nenc_old), lmask(1:nenc_old)) + system%plpl_encounter%lclosest(1:nencmin) = pack(system%plpl_encounter%lclosest(1:nenc_old), lmask(1:nenc_old)) + system%plpl_encounter%status(1:nencmin) = pack(system%plpl_encounter%status(1:nenc_old), lmask(1:nenc_old)) + system%plpl_encounter%tcollision(1:nencmin) = pack(system%plpl_encounter%tcollision(1:nenc_old), lmask(1:nenc_old)) + system%plpl_encounter%level(1:nencmin) = pack(system%plpl_encounter%level(1:nenc_old), lmask(1:nenc_old)) + do i = 1, NDIM + system%plpl_encounter%r1(i, 1:nencmin) = pack(system%plpl_encounter%r1(i, 1:nenc_old), lmask(1:nenc_old)) + system%plpl_encounter%r2(i, 1:nencmin) = pack(system%plpl_encounter%r2(i, 1:nenc_old), lmask(1:nenc_old)) + system%plpl_encounter%v1(i, 1:nencmin) = pack(system%plpl_encounter%v1(i, 1:nenc_old), lmask(1:nenc_old)) + system%plpl_encounter%v2(i, 1:nencmin) = pack(system%plpl_encounter%v2(i, 1:nenc_old), lmask(1:nenc_old)) + end do + end if + end if + end associate + + return + end subroutine swiftest_util_rearray_pl + + + module subroutine swiftest_util_rescale_system(self, param, mscale, dscale, tscale) + !! author: David A. Minton + !! + !! Rescales an nbody system to a new set of units. Inputs are the multipliers on the mass (mscale), distance (dscale), and time units (tscale). + !! Rescales all united quantities in the system, as well as the mass conversion factors, gravitational constant, and Einstein's constant in the parameter object. + implicit none + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters. Returns with new values of the scale vactors and GU + real(DP), intent(in) :: mscale, dscale, tscale !! Scale factors for mass, distance, and time units, respectively. + ! Internals + real(DP) :: vscale + + param%MU2KG = param%MU2KG * mscale + param%DU2M = param%DU2M * dscale + param%TU2S = param%TU2S * tscale + + ! Calculate the G for the system units + param%GU = GC / (param%DU2M**3 / (param%MU2KG * param%TU2S**2)) + + if (param%lgr) then + ! Calculate the inverse speed of light in the system units + param%inv_c2 = einsteinC * param%TU2S / param%DU2M + param%inv_c2 = (param%inv_c2)**(-2) + end if + + vscale = dscale / tscale + + associate(cb => self%cb, pl => self%pl, npl => self%pl%nbody, tp => self%tp, ntp => self%tp%nbody) + + cb%mass = cb%mass / mscale + cb%Gmass = param%GU * cb%mass + cb%radius = cb%radius / dscale + cb%rb(:) = cb%rb(:) / dscale + cb%vb(:) = cb%vb(:) / vscale + cb%rot(:) = cb%rot(:) * tscale + pl%mass(1:npl) = pl%mass(1:npl) / mscale + pl%Gmass(1:npl) = param%GU * pl%mass(1:npl) + pl%radius(1:npl) = pl%radius(1:npl) / dscale + pl%rh(:,1:npl) = pl%rh(:,1:npl) / dscale + pl%vh(:,1:npl) = pl%vh(:,1:npl) / vscale + pl%rb(:,1:npl) = pl%rb(:,1:npl) / dscale + pl%vb(:,1:npl) = pl%vb(:,1:npl) / vscale + pl%rot(:,1:npl) = pl%rot(:,1:npl) * tscale + + end associate + + + return + end subroutine swiftest_util_rescale_system + + + module subroutine swiftest_util_resize_arr_char_string(arr, nnew) + !! author: David A. Minton + !! + !! Resizes an array component of type character string. nnew = 0 will deallocate. + implicit none + ! Arguments + character(len=STRMAX), dimension(:), allocatable, intent(inout) :: arr !! Array to resize + integer(I4B), intent(in) :: nnew !! New size + ! Internals + character(len=STRMAX), dimension(:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated + integer(I4B) :: nold !! Old size + + if (nnew < 0) return + + if (nnew == 0) then + if (allocated(arr)) deallocate(arr) + return + end if + + if (allocated(arr)) then + nold = size(arr) + else + nold = 0 + end if + + if (nnew == nold) return + + allocate(tmp(nnew)) + if (nold > 0) then + if (nnew > nold) then + tmp(1:nold) = arr(1:nold) + tmp(nold+1:nnew) = "" + else + tmp(1:nnew) = arr(1:nnew) + end if + else + tmp(1:nnew) = "" + end if + call move_alloc(tmp, arr) + + return + end subroutine swiftest_util_resize_arr_char_string + + + module subroutine swiftest_util_resize_arr_DP(arr, nnew) + !! author: David A. Minton + !! + !! Resizes an array component of double precision type. Passing nnew = 0 will deallocate. + implicit none + ! Arguments + real(DP), dimension(:), allocatable, intent(inout) :: arr !! Array to resize + integer(I4B), intent(in) :: nnew !! New size + ! Internals + real(DP), dimension(:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated + integer(I4B) :: nold !! Old size + real(DP), parameter :: init_val = 0.0_DP + + if (nnew < 0) return + + if (nnew == 0) then + if (allocated(arr)) deallocate(arr) + return + end if + + if (allocated(arr)) then + nold = size(arr) + else + nold = 0 + end if + + if (nnew == nold) return + + allocate(tmp(nnew)) + if (nold > 0) then + if (nnew > nold) then + tmp(1:nold) = arr(1:nold) + tmp(nold+1:nnew) = init_val + else + tmp(1:nnew) = arr(1:nnew) + end if + else + tmp(1:nnew) = init_val + end if + call move_alloc(tmp, arr) + + return + end subroutine swiftest_util_resize_arr_DP + + + module subroutine swiftest_util_resize_arr_DPvec(arr, nnew) + !! author: David A. Minton + !! + !! Resizes an array component of double precision vectors of size (NDIM, n). Passing nnew = 0 will deallocate. + implicit none + ! Arguments + real(DP), dimension(:,:), allocatable, intent(inout) :: arr !! Array to resize + integer(I4B), intent(in) :: nnew !! New size + ! Internals + real(DP), dimension(:,:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated + integer(I4B) :: nold !! Old size + real(DP), dimension(NDIM), parameter :: init_val = 0.0_DP + integer(I4B) :: i + + if (nnew < 0) return + + if (nnew == 0) then + if (allocated(arr)) deallocate(arr) + return + end if + + if (allocated(arr)) then + nold = size(arr, dim=2) + else + nold = 0 + end if + + if (nnew == nold) return + + allocate(tmp(NDIM, nnew)) + if (nold > 0) then + if (nnew > nold) then + tmp(:,1:nold) = arr(:,1:nold) + do i = nold+1, nnew + tmp(:,i) = init_val(:) + end do + else + tmp(:,1:nnew) = arr(:,1:nnew) + end if + else + do i = 1, nnew + tmp(:, i) = init_val(:) + end do + end if + call move_alloc(tmp, arr) + + return + + return + end subroutine swiftest_util_resize_arr_DPvec + + + module subroutine swiftest_util_resize_arr_I4B(arr, nnew) + !! author: David A. Minton + !! + !! Resizes an array component of integer type. Passing nnew = 0 will deallocate. + implicit none + ! Arguments + integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Array to resize + integer(I4B), intent(in) :: nnew !! New size + ! Internals + integer(I4B), dimension(:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated + integer(I4B) :: nold !! Old size + integer(I4B), parameter :: init_val = -1 + + if (nnew < 0) return + + if (nnew == 0) then + if (allocated(arr)) deallocate(arr) + return + end if + + if (allocated(arr)) then + nold = size(arr) + else + nold = 0 + end if + + if (nnew == nold) return + + allocate(tmp(nnew)) + if (nold > 0) then + if (nnew > nold) then + tmp(1:nold) = arr(1:nold) + tmp(nold+1:nnew) = init_val + else + tmp(1:nnew) = arr(1:nnew) + end if + else + tmp(1:nnew) = init_val + end if + call move_alloc(tmp, arr) + + return + end subroutine swiftest_util_resize_arr_I4B + + + module subroutine swiftest_util_resize_arr_info(arr, nnew) + !! author: David A. Minton + !! + !! Resizes an array component of type character string. Array will only be resized if has previously been allocated. Passing nnew = 0 will deallocate. + implicit none + ! Arguments + type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: arr !! Array to resize + integer(I4B), intent(in) :: nnew !! New size + ! Internals + type(swiftest_particle_info), dimension(:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated + integer(I4B) :: nold !! Old size + + if (nnew < 0) return + + if (nnew == 0) then + if (allocated(arr)) deallocate(arr) + return + end if + + if (allocated(arr)) then + nold = size(arr) + else + nold = 0 + end if + + if (nnew == nold) return + + allocate(tmp(nnew)) + if (nnew > nold) then + call util_copy_particle_info_arr(arr(1:nold), tmp(1:nold)) + else + call util_copy_particle_info_arr(arr(1:nnew), tmp(1:nnew)) + end if + + call move_alloc(tmp, arr) + + return + end subroutine swiftest_util_resize_arr_info + + + module subroutine swiftest_util_resize_arr_logical(arr, nnew) + !! author: David A. Minton + !! + !! Resizes an array component of logical type. Passing nnew = 0 will deallocate. + implicit none + ! Arguments + logical, dimension(:), allocatable, intent(inout) :: arr !! Array to resize + integer(I4B), intent(in) :: nnew !! New size + ! Internals + logical, dimension(:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated + integer(I4B) :: nold !! Old size + logical, parameter :: init_val = .false. + + if (nnew < 0) return + + if (nnew == 0) then + if (allocated(arr)) deallocate(arr) + return + end if + + if (allocated(arr)) then + nold = size(arr) + else + nold = 0 + end if + + if (nnew == nold) return + + allocate(tmp(nnew)) + if (nold > 0) then + if (nnew > nold) then + tmp(1:nold) = arr(1:nold) + tmp(nold+1:nnew) = init_val + else + tmp(1:nnew) = arr(1:nnew) + end if + else + tmp(1:nnew) = init_val + end if + call move_alloc(tmp, arr) + + return + end subroutine swiftest_util_resize_arr_logical + + + module subroutine swiftest_util_resize_body(self, nnew) + !! author: David A. Minton + !! + !! Checks the current size of a Swiftest body against the requested size and resizes it if it is too small. + implicit none + ! Arguments + class(swiftest_body), intent(inout) :: self !! Swiftest body object + integer(I4B), intent(in) :: nnew !! New size neded + + call util_resize(self%info, nnew) + call util_resize(self%id, nnew) + call util_resize(self%status, nnew) + call util_resize(self%lcollision, nnew) + call util_resize(self%lencounter, nnew) + call util_resize(self%ldiscard, nnew) + call util_resize(self%lmask, nnew) + call util_resize(self%mu, nnew) + call util_resize(self%rh, nnew) + call util_resize(self%vh, nnew) + call util_resize(self%rb, nnew) + call util_resize(self%vb, nnew) + call util_resize(self%ah, nnew) + call util_resize(self%aobl, nnew) + call util_resize(self%atide, nnew) + call util_resize(self%agr, nnew) + call util_resize(self%ir3h, nnew) + call util_resize(self%a, nnew) + call util_resize(self%e, nnew) + call util_resize(self%inc, nnew) + call util_resize(self%capom, nnew) + call util_resize(self%omega, nnew) + call util_resize(self%capm, nnew) + self%nbody = count(self%status(1:nnew) /= INACTIVE) + + return + end subroutine swiftest_util_resize_body + + + module subroutine swiftest_util_resize_pl(self, nnew) + !! author: David A. Minton + !! + !! Checks the current size of a Swiftest massive body against the requested size and resizes it if it is too small. + implicit none + ! Arguments + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + integer(I4B), intent(in) :: nnew !! New size neded + + call util_resize_body(self, nnew) + + call util_resize(self%mass, nnew) + call util_resize(self%Gmass, nnew) + call util_resize(self%rhill, nnew) + call util_resize(self%renc, nnew) + call util_resize(self%radius, nnew) + call util_resize(self%rbeg, nnew) + call util_resize(self%rend, nnew) + call util_resize(self%vbeg, nnew) + call util_resize(self%density, nnew) + call util_resize(self%Ip, nnew) + call util_resize(self%rot, nnew) + call util_resize(self%k2, nnew) + call util_resize(self%Q, nnew) + call util_resize(self%tlag, nnew) + call util_resize(self%kin, nnew) + call util_resize(self%lmtiny, nnew) + call util_resize(self%nplenc, nnew) + call util_resize(self%ntpenc, nnew) + + + + if (allocated(self%k_plpl)) deallocate(self%k_plpl) + + return + end subroutine swiftest_util_resize_pl + + + module subroutine swiftest_util_resize_tp(self, nnew) + !! author: David A. Minton + !! + !! Checks the current size of a Swiftest test particle against the requested size and resizes it if it is too small. + implicit none + ! Arguments + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + integer(I4B), intent(in) :: nnew !! New size neded + + call util_resize_body(self, nnew) + + call util_resize(self%nplenc, nnew) + call util_resize(self%isperi, nnew) + call util_resize(self%peri, nnew) + call util_resize(self%atp, nnew) + + return + end subroutine swiftest_util_resize_tp + + + module subroutine swiftest_util_set_beg_end_pl(self, rbeg, rend, vbeg) + !! author: David A. Minton + !! + !! Sets one or more of the values of rbeg, rend, and vbeg + implicit none + ! Arguments + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + real(DP), dimension(:,:), intent(in), optional :: rbeg, rend, vbeg + + if (present(rbeg)) then + if (allocated(self%rbeg)) deallocate(self%rbeg) + allocate(self%rbeg, source=rbeg) + end if + if (present(rend)) then + if (allocated(self%rend)) deallocate(self%rend) + allocate(self%rend, source=rend) + end if + if (present(vbeg)) then + if (allocated(self%vbeg)) deallocate(self%vbeg) + allocate(self%vbeg, source=vbeg) + end if + + return + end subroutine swiftest_util_set_beg_end_pl + + + module subroutine swiftest_util_set_ir3h(self) + !! author: David A. Minton + !! + !! Sets the inverse heliocentric radius term (1/rh**3) for all bodies in a structure + implicit none + ! Arguments + class(swiftest_body), intent(inout) :: self !! Swiftest generic body object + ! Internals + integer(I4B) :: i + real(DP) :: r2, irh + + if (self%nbody > 0) then + + do i = 1, self%nbody + r2 = dot_product(self%rh(:, i), self%rh(:, i)) + irh = 1.0_DP / sqrt(r2) + self%ir3h(i) = irh / r2 + end do + end if + + return + end subroutine swiftest_util_set_ir3h + + + module subroutine swiftest_util_set_msys(self) + !! author: David A. Minton + !! + !! Sets the value of msys and the vector mass quantities based on the total mass of the system + implicit none + ! Arguments + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nobdy system object + + self%Gmtot = self%cb%Gmass + sum(self%pl%Gmass(1:self%pl%nbody), self%pl%status(1:self%pl%nbody) /= INACTIVE) + + return + end subroutine swiftest_util_set_msys + + + module subroutine swiftest_util_set_mu_pl(self, cb) + !! author: David A. Minton + !! + !! Computes G * (M + m) for each massive body + implicit none + ! Arguments + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object + + if (self%nbody > 0) self%mu(1:self%nbody) = cb%Gmass + self%Gmass(1:self%nbody) + + return + end subroutine swiftest_util_set_mu_pl + + + module subroutine swiftest_util_set_mu_tp(self, cb) + !! author: David A. Minton + !! + !! Converts certain scalar values to arrays so that they can be used in elemental functions + implicit none + ! Arguments + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object + + if (self%nbody == 0) return + self%mu(1:self%nbody) = cb%Gmass + + return + end subroutine swiftest_util_set_mu_tp + + + module subroutine swiftest_util_set_particle_info(self, name, particle_type, status, origin_type, origin_time, collision_id, origin_rh,& + origin_vh, discard_time, discard_rh, discard_vh, discard_body_id) + !! author: David A. Minton + !! + !! Sets one or more values of the particle information metadata object + implicit none + ! Arguments + class(swiftest_particle_info), intent(inout) :: self + character(len=*), intent(in), optional :: name !! Non-unique name + character(len=*), intent(in), optional :: particle_type !! String containing a description of the particle type (e.g. Central Body, Massive Body, Test Particle) + character(len=*), intent(in), optional :: status !! Particle status description: ACTIVE, MERGED, FRAGMENTED, etc. + character(len=*), intent(in), optional :: origin_type !! String containing a description of the origin of the particle (e.g. Initial Conditions, Supercatastrophic, Disruption, etc.) + real(DP), intent(in), optional :: origin_time !! The time of the particle's formation + integer(I4B), intent(in), optional :: collision_id !! The ID fo the collision that formed the particle + real(DP), dimension(:), intent(in), optional :: origin_rh !! The heliocentric distance vector at the time of the particle's formation + real(DP), dimension(:), intent(in), optional :: origin_vh !! The heliocentric velocity vector at the time of the particle's formation + real(DP), intent(in), optional :: discard_time !! The time of the particle's discard + real(DP), dimension(:), intent(in), optional :: discard_rh !! The heliocentric distance vector at the time of the particle's discard + real(DP), dimension(:), intent(in), optional :: discard_vh !! The heliocentric velocity vector at the time of the particle's discard + integer(I4B), intent(in), optional :: discard_body_id !! The id of the other body involved in the discard (0 if no other body involved) + ! Internals + character(len=NAMELEN) :: lenstr + character(len=:), allocatable :: fmtlabel + + write(lenstr, *) NAMELEN + fmtlabel = "(A" // trim(adjustl(lenstr)) // ")" + + if (present(name)) then + write(self%name, fmtlabel) trim(adjustl(name)) + end if + if (present(particle_type)) then + write(self%particle_type, fmtlabel) trim(adjustl(particle_type)) + end if + if (present(status)) then + write(self%status, fmtlabel) trim(adjustl(status)) + end if + if (present(origin_type)) then + write(self%origin_type, fmtlabel) trim(adjustl(origin_type)) + end if + if (present(origin_time)) then + self%origin_time = origin_time + end if + if (present(collision_id)) then + self%collision_id = collision_id + end if + if (present(origin_rh)) then + self%origin_rh(:) = origin_rh(:) + end if + if (present(origin_vh)) then + self%origin_vh(:) = origin_vh(:) + end if + if (present(discard_time)) then + self%discard_time = discard_time + end if + if (present(discard_rh)) then + self%discard_rh(:) = discard_rh(:) + end if + if (present(discard_vh)) then + self%discard_vh(:) = discard_vh(:) + end if + if (present(discard_body_id)) then + self%discard_body_id = discard_body_id + end if + + return + end subroutine swiftest_util_set_particle_info + + + module subroutine swiftest_util_set_renc_I4B(self, scale) + !! author: David A. Minton + !! + !! Sets the critical radius for encounter given an input scale factor + !! + implicit none + ! Arguments + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + integer(I4B), intent(in) :: scale !! Input scale factor (multiplier of Hill's sphere size) + + associate(pl => self, npl => self%nbody) + pl%renc(1:npl) = pl%rhill(1:npl) * scale + end associate + + return + end subroutine swiftest_util_set_renc_I4B + + + module subroutine swiftest_util_set_renc_DP(self, scale) + !! author: David A. Minton + !! + !! Sets the critical radius for encounter given an input scale factor + !! + implicit none + ! Arguments + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + real(DP), intent(in) :: scale !! Input scale factor (multiplier of Hill's sphere size) + + associate(pl => self, npl => self%nbody) + pl%renc(1:npl) = pl%rhill(1:npl) * scale + end associate + + return + end subroutine swiftest_util_set_renc_DP + + + module subroutine swiftest_util_set_rhill(self,cb) + !! author: David A. Minton + !! + !! Sets the value of the Hill's radius + implicit none + ! Arguments + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object + + if (self%nbody == 0) return + + call self%xv2el(cb) + self%rhill(1:self%nbody) = self%a(1:self%nbody) * (self%Gmass(1:self%nbody) / cb%Gmass / 3)**THIRD + + return + end subroutine swiftest_util_set_rhill + + + module subroutine swiftest_util_set_rhill_approximate(self,cb) + !! author: David A. Minton + !! + !! Sets the approximate value of the Hill's radius using the heliocentric radius instead of computing the semimajor axis + implicit none + ! Arguments + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object + ! Internals + real(DP), dimension(:), allocatable :: rh + + if (self%nbody == 0) return + + rh(1:self%nbody) = .mag. self%rh(:,1:self%nbody) + self%rhill(1:self%nbody) = rh(1:self%nbody) * (self%Gmass(1:self%nbody) / cb%Gmass / 3)**THIRD + + return + end subroutine swiftest_util_set_rhill_approximate + + + module subroutine swiftest_util_snapshot_system(self, param, system, t, arg) + !! author: David A. Minton + !! + !! Takes a snapshot of the system for later file storage + implicit none + ! Arguments + class(swiftest_storage(*)), intent(inout) :: self !! Swiftest storage object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object to store + real(DP), intent(in), optional :: t !! Time of snapshot if different from system time + character(*), intent(in), optional :: arg !! Optional argument (needed for extended storage type used in collision snapshots) + + self%iframe = self%iframe + 1 + self%nt = self%iframe + self%frame(self%iframe) = system ! Store a snapshot of the system for posterity + self%nid = self%nid + 1 ! Central body + if (allocated(system%pl)) self%nid = self%nid + system%pl%nbody + if (allocated(system%tp)) self%nid = self%nid + system%tp%nbody + + return + end subroutine swiftest_util_snapshot_system + + + module function swiftest_util_solve_linear_system_d(A,b,n,lerr) result(x) + !! Author: David A. Minton + !! + !! Solves the linear equation of the form A*x = b for x. + !! A is an (n,n) arrays + !! x and b are (n) arrays + !! Uses Gaussian elimination, so will have issues if system is ill-conditioned. + !! Uses quad precision intermidiate values, so works best on small arrays. + use, intrinsic :: ieee_exceptions + implicit none + ! Arguments + integer(I4B), intent(in) :: n + real(DP), dimension(:,:), intent(in) :: A + real(DP), dimension(:), intent(in) :: b + logical, intent(out) :: lerr + ! Result + real(DP), dimension(n) :: x + ! Internals + real(QP), dimension(:), allocatable :: qx + type(ieee_status_type) :: original_fpe_status + logical, dimension(:), allocatable :: fpe_flag + + call ieee_get_status(original_fpe_status) ! Save the original floating point exception status + call ieee_set_flag(ieee_all, .false.) ! Set all flags to quiet + allocate(fpe_flag(size(ieee_usual))) + + qx = solve_wbs(ge_wpp(real(A, kind=QP), real(b, kind=QP))) + + call ieee_get_flag(ieee_usual, fpe_flag) + lerr = any(fpe_flag) + if (lerr .or. (any(abs(qx) > huge(x))) .or. (any(abs(qx) < tiny(x)))) then + x = 0.0_DP + else + x = real(qx, kind=DP) + end if + call ieee_set_status(original_fpe_status) + + return + end function util_solve_linear_system_d + + + module function swiftest_util_solve_linear_system_q(A,b,n,lerr) result(x) + !! Author: David A. Minton + !! + !! Solves the linear equation of the form A*x = b for x. + !! A is an (n,n) arrays + !! x and b are (n) arrays + !! Uses Gaussian elimination, so will have issues if system is ill-conditioned. + !! Uses quad precision intermidiate values, so works best on small arrays. + use, intrinsic :: ieee_exceptions + implicit none + ! Arguments + integer(I4B), intent(in) :: n + real(QP), dimension(:,:), intent(in) :: A + real(QP), dimension(:), intent(in) :: b + logical, intent(out) :: lerr + ! Result + real(QP), dimension(n) :: x + ! Internals + type(ieee_status_type) :: original_fpe_status + logical, dimension(:), allocatable :: fpe_flag + + call ieee_get_status(original_fpe_status) ! Save the original floating point exception status + call ieee_set_flag(ieee_all, .false.) ! Set all flags to quiet + allocate(fpe_flag(size(ieee_usual))) + + x = solve_wbs(ge_wpp(A, b)) + + call ieee_get_flag(ieee_usual, fpe_flag) + lerr = any(fpe_flag) + if (lerr) x = 0.0_DP + call ieee_set_status(original_fpe_status) + + return + end function util_solve_linear_system_q + + function solve_wbs(u) result(x) ! solve with backward substitution + !! Based on code available on Rosetta Code: https://rosettacode.org/wiki/Gaussian_elimination#Fortran + use, intrinsic :: ieee_exceptions + use swiftest + implicit none + ! Arguments + real(QP), intent(in), dimension(:,:), allocatable :: u + ! Result + real(QP), dimension(:), allocatable :: x + ! Internals + integer(I4B) :: i,n + + n = size(u, 1) + if (allocated(x)) deallocate(x) + if (.not.allocated(x)) allocate(x(n)) + if (any(abs(u) < tiny(1._DP)) .or. any(abs(u) > huge(1._DP))) then + x(:) = 0._DP + return + end if + call ieee_set_halting_mode(ieee_divide_by_zero, .false.) + do i = n, 1, -1 + x(i) = (u(i, n + 1) - sum(u(i, i + 1:n) * x(i + 1:n))) / u(i, i) + end do + return + end function solve_wbs + + + function ge_wpp(A, b) result(u) ! gaussian eliminate with partial pivoting + !! Solve Ax=b using Gaussian elimination then backwards substitution. + !! A being an n by n matrix. + !! x and b are n by 1 vectors. + !! Based on code available on Rosetta Code: https://rosettacode.org/wiki/Gaussian_elimination#Fortran + use, intrinsic :: ieee_exceptions + use swiftest + implicit none + ! Arguments + real(QP), dimension(:,:), intent(in) :: A + real(QP), dimension(:), intent(in) :: b + ! Result + real(QP), dimension(:,:), allocatable :: u + ! Internals + integer(I4B) :: i,j,n,p + real(QP) :: upi + + n = size(a, 1) + allocate(u(n, (n + 1))) + u = reshape([A, b], [n, n + 1]) + call ieee_set_halting_mode(ieee_divide_by_zero, .false.) + do j = 1, n + p = maxloc(abs(u(j:n, j)), 1) + j - 1 ! maxloc returns indices between (1, n - j + 1) + if (p /= j) u([p, j], j) = u([j, p], j) + u(j + 1:, j) = u(j + 1:, j) / u(j, j) + do i = j + 1, n + 1 + upi = u(p, i) + if (p /= j) u([p, j], i) = u([j, p], i) + u(j + 1:n, i) = u(j + 1:n, i) - upi * u(j + 1:n, j) + end do + end do + return + end function ge_wpp + + + module function swiftest_util_solve_rkf45(f, y0in, t1, dt0, tol) result(y1) + !! author: David A. Minton + !! + !! Implements the 4th order Runge-Kutta-Fehlberg ODE solver for initial value problems of the form f=dy/dt, y0 = y(t=0), solving for y1 = y(t=t1). Uses a 5th order adaptive step size control. + !! Uses a lambda function object as defined in the lambda_function module + implicit none + ! Arguments + class(lambda_obj), intent(inout) :: f !! lambda function object that has been initialized to be a function of derivatives. The object will return with components lastarg and lasteval set + real(DP), dimension(:), intent(in) :: y0in !! Initial value at t=0 + real(DP), intent(in) :: t1 !! Final time + real(DP), intent(in) :: dt0 !! Initial step size guess + real(DP), intent(in) :: tol !! Tolerance on solution + ! Result + real(DP), dimension(:), allocatable :: y1 !! Final result + ! Internals + integer(I4B), parameter :: MAXREDUX = 1000 !! Maximum number of times step size can be reduced + real(DP), parameter :: DTFAC = 0.95_DP !! Step size reduction safety factor (Value just under 1.0 to prevent adaptive step size control from discarding steps too aggressively) + integer(I4B), parameter :: RKS = 6 !! Number of RK stages + real(DP), dimension(RKS, RKS - 1), parameter :: rkf45_btab = reshape( & !! Butcher tableau for Runge-Kutta-Fehlberg method + (/ 1./4., 1./4., 0., 0., 0., 0.,& + 3./8., 3./32., 9./32., 0., 0., 0.,& + 12./13., 1932./2197., -7200./2197., 7296./2197., 0., 0.,& + 1., 439./216., -8., 3680./513., -845./4104., 0.,& + 1./2., -8./27., 2., -3544./2565., 1859./4104., -11./40./), shape(rkf45_btab)) + real(DP), dimension(RKS), parameter :: rkf4_coeff = (/ 25./216., 0., 1408./2565. , 2197./4104. , -1./5., 0. /) + real(DP), dimension(RKS), parameter :: rkf5_coeff = (/ 16./135., 0., 6656./12825., 28561./56430., -9./50., 2./55. /) + real(DP), dimension(:, :), allocatable :: k !! Runge-Kutta coefficient vector + real(DP), dimension(:), allocatable :: ynorm !! Normalized y value used for adaptive step size control + real(DP), dimension(:), allocatable :: y0 !! Value of y at the beginning of each substep + integer(I4B) :: Nvar !! Number of variables in problem + integer(I4B) :: rkn !! Runge-Kutta loop index + real(DP) :: t, x1, dt, trem !! Current time, step size and total time remaining + real(DP) :: s, yerr, yscale !! Step size reduction factor, error in dependent variable, and error scale factor + integer(I4B) :: i + + allocate(y0, source=y0in) + allocate(y1, mold=y0) + allocate(ynorm, mold=y0) + Nvar = size(y0) + allocate(k(Nvar, RKS)) + + dt = dt0 + + trem = t1 + t = 0._DP + do + yscale = norm2(y0(:)) + do i = 1, MAXREDUX + select type(f) + class is (lambda_obj_tvar) + do rkn = 1, RKS + y1(:) = y0(:) + matmul(k(:, 1:rkn - 1), rkf45_btab(2:rkn, rkn - 1)) + if (rkn == 1) then + x1 = t + else + x1 = t + rkf45_btab(1,rkn-1) + end if + k(:, rkn) = dt * f%evalt(y1(:), t) + end do + class is (lambda_obj) + do rkn = 1, RKS + y1(:) = y0(:) + matmul(k(:, 1:rkn - 1), rkf45_btab(2:rkn, rkn - 1)) + k(:, rkn) = dt * f%eval(y1(:)) + end do + end select + ! Now determine if the step size needs adjusting + ynorm(:) = matmul(k(:,:), (rkf5_coeff(:) - rkf4_coeff(:))) / yscale + yerr = norm2(ynorm(:)) + s = (tol / (2 * yerr))**(0.25_DP) + dt = min(s * DTFAC * dt, trem) ! Alter step size either up or down, but never bigger than the remaining time + if (s >= 1.0_DP) exit ! Good step! + if (i == MAXREDUX) then + write(*,*) "Something has gone wrong in util_solve_rkf45!! Step size reduction has gone too far this time!" + call util_exit(FAILURE) + end if + end do + + ! Compute new value then step ahead in time + y1(:) = y0(:) + matmul(k(:, :), rkf4_coeff(:)) + trem = trem - dt + t = t + dt + if (trem <= 0._DP) exit + y0(:) = y1(:) + end do + + return + end function util_solve_rkf45 + + + + module subroutine swiftest_util_sort_body(self, sortby, ascending) + !! author: David A. Minton + !! + !! Sort a Swiftest body structure in-place. + !! sortby is a string indicating which array component to sort. + implicit none + ! Arguments + class(swiftest_body), intent(inout) :: self !! Swiftest body object + character(*), intent(in) :: sortby !! Sorting attribute + logical, intent(in) :: ascending !! Logical flag indicating whether or not the sorting should be in ascending or descending order + ! Internals + integer(I4B), dimension(:), allocatable :: ind + integer(I4B) :: direction + + if (self%nbody == 0) return + + if (ascending) then + direction = 1 + else + direction = -1 + end if + + associate(body => self, n => self%nbody) + select case(sortby) + case("id") + call util_sort(direction * body%id(1:n), ind) + case("status") + call util_sort(direction * body%status(1:n), ind) + case("ir3h") + call util_sort(direction * body%ir3h(1:n), ind) + case("a") + call util_sort(direction * body%a(1:n), ind) + case("e") + call util_sort(direction * body%e(1:n), ind) + case("inc") + call util_sort(direction * body%inc(1:n), ind) + case("capom") + call util_sort(direction * body%capom(1:n), ind) + case("mu") + call util_sort(direction * body%mu(1:n), ind) + case("lfirst", "nbody", "ldiscard", "rh", "vh", "rb", "vb", "ah", "aobl", "atide", "agr") + write(*,*) 'Cannot sort by ' // trim(adjustl(sortby)) // '. Component not sortable!' + case default + write(*,*) 'Cannot sort by ' // trim(adjustl(sortby)) // '. Component not found!' + return + end select + + call body%rearrange(ind) + + end associate + + return + end subroutine swiftest_util_sort_body + + + pure module subroutine swiftest_util_sort_dp(arr) + !! author: David A. Minton + !! + !! Sort input DP precision array in place into ascending numerical order using quicksort. + !! + implicit none + ! Arguments + real(DP), dimension(:), intent(inout) :: arr + + call qsort_DP(arr) + + return + end subroutine swiftest_util_sort_dp + + + pure module subroutine swiftest_util_sort_index_dp(arr, ind) + !! author: David A. Minton + !! + !! Sort input DP precision array by index in ascending numerical order using quick sort. + !! This algorithm works well for partially sorted arrays (which is usually the case here). + !! If ind is supplied already allocated, we assume it is an existing index array (e.g. a previously + !! sorted array). If it is not allocated, this subroutine swiftest_allocates it. + !! + implicit none + ! Arguments + real(DP), dimension(:), intent(in) :: arr + integer(I4B), dimension(:), allocatable, intent(inout) :: ind + ! Internals + integer(I4B) :: n, i + real(DP), dimension(:), allocatable :: tmparr + + n = size(arr) + if (.not.allocated(ind)) then + allocate(ind(n)) + ind = [(i, i=1, n)] + end if + allocate(tmparr, mold=arr) + tmparr(:) = arr(ind(:)) + call qsort_DP(tmparr, ind) + + return + end subroutine swiftest_util_sort_index_dp + + + recursive pure subroutine swiftest_qsort_DP(arr, ind) + !! author: David A. Minton + !! + !! Sort input DP precision array by index in ascending numerical order using quicksort sort. + !! + implicit none + ! Arguments + real(DP), dimension(:), intent(inout) :: arr + integer(I4B),dimension(:),intent(out), optional :: ind + !! Internals + integer :: iq + + if (size(arr) > 1) then + if (present(ind)) then + call partition_DP(arr, iq, ind) + call qsort_DP(arr(:iq-1),ind(:iq-1)) + call qsort_DP(arr(iq:), ind(iq:)) + else + call partition_DP(arr, iq) + call qsort_DP(arr(:iq-1)) + call qsort_DP(arr(iq:)) + end if + end if + + return + end subroutine swiftest_qsort_DP + + + pure subroutine swiftest_partition_DP(arr, marker, ind) + !! author: David A. Minton + !! + !! Partition function for quicksort on DP type + !! + implicit none + ! Arguments + real(DP), intent(inout), dimension(:) :: arr + integer(I4B), intent(inout), dimension(:), optional :: ind + integer(I4B), intent(out) :: marker + ! Internals + integer(I4B) :: i, j, itmp, narr, ipiv + real(DP) :: temp + real(DP) :: x ! pivot point + + narr = size(arr) + + ! Get center as pivot, as this is likely partially sorted + ipiv = narr / 2 + x = arr(ipiv) + i = 0 + j = narr + 1 + + do + j = j - 1 + do + if (arr(j) <= x) exit + j = j - 1 + end do + i = i + 1 + do + if (arr(i) >= x) exit + i = i + 1 + end do + if (i < j) then + ! exchange A(i) and A(j) + temp = arr(i) + arr(i) = arr(j) + arr(j) = temp + if (present(ind)) then + itmp = ind(i) + ind(i) = ind(j) + ind(j) = itmp + end if + else if (i == j) then + marker = i + 1 + return + else + marker = i + return + endif + end do + + return + end subroutine swiftest_partition_DP + + + pure module subroutine swiftest_util_sort_i4b(arr) + !! author: David A. Minton + !! + !! Sort input integer array in place into ascending numerical order using quick sort. + !! This algorithm works well for partially sorted arrays (which is usually the case here) + !! + implicit none + ! Arguments + integer(I4B), dimension(:), intent(inout) :: arr + + call qsort_I4B(arr) + + return + end subroutine swiftest_util_sort_i4b + + + pure module subroutine swiftest_util_sort_index_I4B(arr, ind) + !! author: David A. Minton + !! + !! Sort input integer array by index in ascending numerical order using quicksort. + !! If ind is supplied already allocated, we assume it is an existing index array (e.g. a previously + !! sorted array). If it is not allocated, this subroutine swiftest_allocates it. + !! + implicit none + ! Arguments + integer(I4B), dimension(:), intent(in) :: arr + integer(I4B), dimension(:), allocatable, intent(inout) :: ind + ! Internals + integer(I4B) :: n, i + integer(I4B), dimension(:), allocatable :: tmparr + + n = size(arr) + if (.not.allocated(ind)) then + allocate(ind(n)) + ind = [(i, i=1, n)] + end if + allocate(tmparr, mold=arr) + tmparr(:) = arr(ind(:)) + call qsort_I4B(tmparr, ind) + + return + end subroutine swiftest_util_sort_index_I4B + + + pure module subroutine swiftest_util_sort_index_I4B_I8Bind(arr, ind) + !! author: David A. Minton + !! + !! Sort input integer array by index in ascending numerical order using quicksort. + !! If ind is supplied already allocated, we assume it is an existing index array (e.g. a previously + !! sorted array). If it is not allocated, this subroutine swiftest_allocates it. + !! + implicit none + ! Arguments + integer(I4B), dimension(:), intent(in) :: arr + integer(I8B), dimension(:), allocatable, intent(inout) :: ind + ! Internals + integer(I8B) :: n, i + integer(I4B), dimension(:), allocatable :: tmparr + + n = size(arr) + if (.not.allocated(ind)) then + allocate(ind(n)) + ind = [(i, i=1_I8B, n)] + end if + allocate(tmparr, mold=arr) + tmparr(:) = arr(ind(:)) + call qsort_I4B_I8Bind(tmparr, ind) + + return + end subroutine swiftest_util_sort_index_I4B_I8Bind + + + recursive pure subroutine swiftest_qsort_I4B(arr, ind) + !! author: David A. Minton + !! + !! Sort input I4B array by index in ascending numerical order using quicksort. + !! + implicit none + ! Arguments + integer(I4B), dimension(:), intent(inout) :: arr + integer(I4B), dimension(:), intent(out), optional :: ind + ! Internals + integer(I4B) :: iq + + if (size(arr) > 1) then + if (present(ind)) then + call partition_I4B(arr, iq, ind) + call qsort_I4B(arr(:iq-1),ind(:iq-1)) + call qsort_I4B(arr(iq:), ind(iq:)) + else + call partition_I4B(arr, iq) + call qsort_I4B(arr(:iq-1)) + call qsort_I4B(arr(iq:)) + end if + end if + + return + end subroutine swiftest_qsort_I4B + + recursive pure subroutine swiftest_qsort_I4B_I8Bind(arr, ind) + !! author: David A. Minton + !! + !! Sort input I4B array by index in ascending numerical order using quicksort. + !! + implicit none + ! Arguments + integer(I4B), dimension(:), intent(inout) :: arr + integer(I8B), dimension(:), intent(out), optional :: ind + ! Internals + integer(I8B) :: iq + + if (size(arr) > 1_I8B) then + if (present(ind)) then + call partition_I4B_I8Bind(arr, iq, ind) + call qsort_I4B_I8Bind(arr(:iq-1_I8B),ind(:iq-1_I8B)) + call qsort_I4B_I8Bind(arr(iq:), ind(iq:)) + else + call partition_I4B_I8Bind(arr, iq) + call qsort_I4B_I8Bind(arr(:iq-1_I8B)) + call qsort_I4B_I8Bind(arr(iq:)) + end if + end if + + return + end subroutine swiftest_qsort_I4B_I8Bind + + + recursive pure subroutine swiftest_qsort_I8B_I8Bind(arr, ind) + !! author: David A. Minton + !! + !! Sort input I8B array by index in ascending numerical order using quicksort. + !! + implicit none + ! Arguments + integer(I8B), dimension(:), intent(inout) :: arr + integer(I8B), dimension(:), intent(out), optional :: ind + ! Internals + integer(I8B) :: iq + + if (size(arr) > 1_I8B) then + if (present(ind)) then + call partition_I8B_I8Bind(arr, iq, ind) + call qsort_I8B_I8Bind(arr(:iq-1_I8B),ind(:iq-1_I8B)) + call qsort_I8B_I8Bind(arr(iq:), ind(iq:)) + else + call partition_I8B_I8Bind(arr, iq) + call qsort_I8B_I8Bind(arr(:iq-1_I8B)) + call qsort_I8B_I8Bind(arr(iq:)) + end if + end if + + return + end subroutine swiftest_qsort_I8B_I8Bind + + + pure subroutine swiftest_partition_I4B(arr, marker, ind) + !! author: David A. Minton + !! + !! Partition function for quicksort on I4B type + !! + implicit none + ! Arguments + integer(I4B), intent(inout), dimension(:) :: arr + integer(I4B), intent(inout), dimension(:), optional :: ind + integer(I4B), intent(out) :: marker + ! Internals + integer(I4B) :: i, j, itmp, narr, ipiv + integer(I4B) :: temp + integer(I4B) :: x ! pivot point + + narr = size(arr) + + ! Get center as pivot, as this is likely partially sorted + ipiv = narr / 2 + x = arr(ipiv) + i = 0 + j = narr + 1 + + do + j = j - 1 + do + if (arr(j) <= x) exit + j = j - 1 + end do + i = i + 1 + do + if (arr(i) >= x) exit + i = i + 1 + end do + if (i < j) then + ! exchange A(i) and A(j) + temp = arr(i) + arr(i) = arr(j) + arr(j) = temp + if (present(ind)) then + itmp = ind(i) + ind(i) = ind(j) + ind(j) = itmp + end if + else if (i == j) then + marker = i + 1 + return + else + marker = i + return + endif + end do + + return + end subroutine swiftest_partition_I4B + + pure subroutine swiftest_partition_I4B_I8Bind(arr, marker, ind) + !! author: David A. Minton + !! + !! Partition function for quicksort on I4B type + !! + implicit none + ! Arguments + integer(I4B), intent(inout), dimension(:) :: arr + integer(I8B), intent(inout), dimension(:), optional :: ind + integer(I8B), intent(out) :: marker + ! Internals + integer(I8B) :: i, j, itmp, narr, ipiv + integer(I4B) :: temp + integer(I8B) :: x ! pivot point + + narr = size(arr) + + ! Get center as pivot, as this is likely partially sorted + ipiv = narr / 2_I8B + x = arr(ipiv) + i = 0_I8B + j = narr + 1_I8B + + do + j = j - 1_I8B + do + if (arr(j) <= x) exit + j = j - 1_I8B + end do + i = i + 1_I8B + do + if (arr(i) >= x) exit + i = i + 1_I8B + end do + if (i < j) then + ! exchange A(i) and A(j) + temp = arr(i) + arr(i) = arr(j) + arr(j) = temp + if (present(ind)) then + itmp = ind(i) + ind(i) = ind(j) + ind(j) = itmp + end if + else if (i == j) then + marker = i + 1_I8B + return + else + marker = i + return + endif + end do + + return + end subroutine swiftest_partition_I4B_I8Bind + + pure subroutine swiftest_partition_I8B_I8Bind(arr, marker, ind) + !! author: David A. Minton + !! + !! Partition function for quicksort on I8B type with I8B index + !! + implicit none + ! Arguments + integer(I8B), intent(inout), dimension(:) :: arr + integer(I8B), intent(inout), dimension(:), optional :: ind + integer(I8B), intent(out) :: marker + ! Internals + integer(I8B) :: i, j, itmp, narr, ipiv + integer(I8B) :: temp + integer(I8B) :: x ! pivot point + + narr = size(arr) + + ! Get center as pivot, as this is likely partially sorted + ipiv = narr / 2_I8B + x = arr(ipiv) + i = 0_I8B + j = narr + 1_I8B + + do + j = j - 1_I8B + do + if (arr(j) <= x) exit + j = j - 1_I8B + end do + i = i + 1_I8B + do + if (arr(i) >= x) exit + i = i + 1_I8B + end do + if (i < j) then + ! exchange A(i) and A(j) + temp = arr(i) + arr(i) = arr(j) + arr(j) = temp + if (present(ind)) then + itmp = ind(i) + ind(i) = ind(j) + ind(j) = itmp + end if + else if (i == j) then + marker = i + 1_I8B + return + else + marker = i + return + endif + end do + + return + end subroutine swiftest_partition_I8B_I8Bind + + + pure module subroutine swiftest_util_sort_sp(arr) + !! author: David A. Minton + !! + !! Sort input DP precision array in place into ascending numerical order using quicksort. + !! + implicit none + ! Arguments + real(SP), dimension(:), intent(inout) :: arr + + call qsort_SP(arr) + + return + end subroutine swiftest_util_sort_sp + + + pure module subroutine swiftest_util_sort_index_sp(arr, ind) + !! author: David A. Minton + !! + !! Sort input DP precision array by index in ascending numerical order using quicksort. + !! If ind is supplied already allocated, we assume it is an existing index array (e.g. a previously + !! sorted array). If it is not allocated, this subroutine swiftest_allocates it. + !! + implicit none + ! Arguments + real(SP), dimension(:), intent(in) :: arr + integer(I4B), dimension(:), allocatable, intent(inout) :: ind + ! Internals + integer(I4B) :: n, i + real(SP), dimension(:), allocatable :: tmparr + + n = size(arr) + if (.not.allocated(ind)) then + allocate(ind(n)) + ind = [(i, i=1, n)] + end if + allocate(tmparr, mold=arr) + tmparr(:) = arr(ind(:)) + call qsort_SP(tmparr, ind) + + return + end subroutine swiftest_util_sort_index_sp + + + recursive pure subroutine swiftest_qsort_SP(arr, ind) + !! author: David A. Minton + !! + !! Sort input DP precision array by index in ascending numerical order using quicksort. + !! + implicit none + ! Arguments + real(SP), dimension(:), intent(inout) :: arr + integer(I4B),dimension(:),intent(out), optional :: ind + !! Internals + integer :: iq + + if (size(arr) > 1) then + if (present(ind)) then + call partition_SP(arr, iq, ind) + call qsort_SP(arr(:iq-1),ind(:iq-1)) + call qsort_SP(arr(iq:), ind(iq:)) + else + call partition_SP(arr, iq) + call qsort_SP(arr(:iq-1)) + call qsort_SP(arr(iq:)) + end if + end if + + return + end subroutine swiftest_qsort_SP + + + pure subroutine swiftest_partition_SP(arr, marker, ind) + !! author: David A. Minton + !! + !! Partition function for quicksort on SP type + !! + implicit none + ! Arguments + real(SP), intent(inout), dimension(:) :: arr + integer(I4B), intent(inout), dimension(:), optional :: ind + integer(I4B), intent(out) :: marker + ! Internals + integer(I4B) :: i, j, itmp, narr, ipiv + real(SP) :: temp + real(SP) :: x ! pivot point + + narr = size(arr) + + ! Get center as pivot, as this is likely partially sorted + ipiv = narr / 2 + x = arr(ipiv) + i = 0 + j = narr + 1 + + do + j = j - 1 + do + if (arr(j) <= x) exit + j = j - 1 + end do + i = i + 1 + do + if (arr(i) >= x) exit + i = i + 1 + end do + if (i < j) then + ! exchange A(i) and A(j) + temp = arr(i) + arr(i) = arr(j) + arr(j) = temp + if (present(ind)) then + itmp = ind(i) + ind(i) = ind(j) + ind(j) = itmp + end if + else if (i == j) then + marker = i + 1 + return + else + marker = i + return + endif + end do + + return + end subroutine swiftest_partition_SP + + + module subroutine swiftest_util_sort_pl(self, sortby, ascending) + !! author: David A. Minton + !! + !! Sort a Swiftest massive body object in-place. + !! sortby is a string indicating which array component to sort. + implicit none + ! Arguments + class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object + character(*), intent(in) :: sortby !! Sorting attribute + logical, intent(in) :: ascending !! Logical flag indicating whether or not the sorting should be in ascending or descending order + ! Internals + integer(I4B), dimension(:), allocatable :: ind + integer(I4B) :: direction + + if (self%nbody == 0) return + + if (ascending) then + direction = 1 + else + direction = -1 + end if + + associate(pl => self, npl => self%nbody) + select case(sortby) + case("Gmass","mass") + call util_sort(direction * pl%Gmass(1:npl), ind) + case("rhill") + call util_sort(direction * pl%rhill(1:npl), ind) + case("renc") + call util_sort(direction * pl%renc(1:npl), ind) + case("radius") + call util_sort(direction * pl%radius(1:npl), ind) + case("density") + call util_sort(direction * pl%density(1:npl), ind) + case("k2") + call util_sort(direction * pl%k2(1:npl), ind) + case("Q") + call util_sort(direction * pl%Q(1:npl), ind) + case("tlag") + call util_sort(direction * pl%tlag(1:npl), ind) + case("rbeg", "rend", "vbeg", "Ip", "rot", "k_plpl", "nplpl") + write(*,*) 'Cannot sort by ' // trim(adjustl(sortby)) // '. Component not sortable!' + case default ! Look for components in the parent class + call util_sort_body(pl, sortby, ascending) + return + end select + + call pl%rearrange(ind) + + end associate + + return + end subroutine swiftest_util_sort_pl + + + module subroutine swiftest_util_sort_tp(self, sortby, ascending) + !! author: David A. Minton + !! + !! Sort a Swiftest test particle object in-place. + !! sortby is a string indicating which array component to sort. + implicit none + ! Arguments + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object + character(*), intent(in) :: sortby !! Sorting attribute + logical, intent(in) :: ascending !! Logical flag indicating whether or not the sorting should be in ascending or descending order + ! Internals + integer(I4B), dimension(:), allocatable :: ind + integer(I4B) :: direction + + if (self%nbody == 0) return + + if (ascending) then + direction = 1 + else + direction = -1 + end if + + associate(tp => self, ntp => self%nbody) + select case(sortby) + case("peri") + call util_sort(direction * tp%peri(1:ntp), ind) + case("atp") + call util_sort(direction * tp%atp(1:ntp), ind) + case("isperi") + write(*,*) 'Cannot sort by ' // trim(adjustl(sortby)) // '. Component not sortable!' + case default ! Look for components in the parent class + call util_sort_body(tp, sortby, ascending) + return + end select + + call tp%rearrange(ind) + + end associate + + return + end subroutine swiftest_util_sort_tp + + + module subroutine swiftest_util_sort_rearrange_body(self, ind) + !! author: David A. Minton + !! + !! Rearrange Swiftest body structure in-place from an index list. + !! This is a helper utility used to make polymorphic sorting work on Swiftest structures. + implicit none + ! Arguments + class(swiftest_body), intent(inout) :: self !! Swiftest 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) + + associate(n => self%nbody) + call util_sort_rearrange(self%id, ind, n) + call util_sort_rearrange(self%lmask, ind, n) + call util_sort_rearrange(self%info, ind, n) + call util_sort_rearrange(self%status, ind, n) + call util_sort_rearrange(self%ldiscard, ind, n) + call util_sort_rearrange(pl%lcollision, ind, n) + call util_sort_rearrange(pl%lencounter, ind, n) + call util_sort_rearrange(self%rh, ind, n) + call util_sort_rearrange(self%vh, ind, n) + call util_sort_rearrange(self%rb, ind, n) + call util_sort_rearrange(self%vb, ind, n) + call util_sort_rearrange(self%ah, ind, n) + call util_sort_rearrange(self%aobl, ind, n) + call util_sort_rearrange(self%agr, ind, n) + call util_sort_rearrange(self%atide, ind, n) + call util_sort_rearrange(self%ir3h, ind, n) + call util_sort_rearrange(self%isperi, ind, n) + call util_sort_rearrange(self%peri, ind, n) + call util_sort_rearrange(self%atp, ind, n) + call util_sort_rearrange(self%mu, ind, n) + call util_sort_rearrange(self%a, ind, n) + call util_sort_rearrange(self%e, ind, n) + call util_sort_rearrange(self%inc, ind, n) + call util_sort_rearrange(self%capom, ind, n) + call util_sort_rearrange(self%omega, ind, n) + call util_sort_rearrange(self%capm, ind, n) + end associate + + return + end subroutine swiftest_util_sort_rearrange_body + + + pure module subroutine swiftest_util_sort_rearrange_arr_char_string(arr, ind, n) + !! author: David A. Minton + !! + !! Rearrange a single array of character string in-place from an index list. + implicit none + ! Arguments + character(len=STRMAX), dimension(:), allocatable, intent(inout) :: arr !! Destination array + integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against + integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange + ! Internals + character(len=STRMAX), dimension(:), allocatable :: tmp !! Temporary copy of arry used during rearrange operation + + if (.not. allocated(arr) .or. n <= 0) return + allocate(tmp, mold=arr) + tmp(1:n) = arr(ind) + call move_alloc(tmp, arr) + + return + end subroutine swiftest_util_sort_rearrange_arr_char_string + + + pure module subroutine swiftest_util_sort_rearrange_arr_DP(arr, ind, n) + !! author: David A. Minton + !! + !! Rearrange a single array of DP type in-place from an index list. + implicit none + ! Arguments + real(DP), dimension(:), allocatable, intent(inout) :: arr !! Destination array + integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against + integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange + ! Internals + real(DP), dimension(:), allocatable :: tmp !! Temporary copy of array used during rearrange operation + + if (.not. allocated(arr) .or. n <= 0) return + allocate(tmp, mold=arr) + tmp(1:n) = arr(ind) + call move_alloc(tmp, arr) + + return + end subroutine swiftest_util_sort_rearrange_arr_DP + + + pure module subroutine swiftest_util_sort_rearrange_arr_DPvec(arr, ind, n) + !! author: David A. Minton + !! + !! Rearrange a single array of (NDIM,n) DP-type vectors in-place from an index list. + implicit none + ! Arguments + real(DP), dimension(:,:), allocatable, intent(inout) :: arr !! Destination array + integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against + integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange + ! Internals + real(DP), dimension(:,:), allocatable :: tmp !! Temporary copy of array used during rearrange operation + + if (.not. allocated(arr) .or. n <= 0) return + allocate(tmp, mold=arr) + tmp(:,1:n) = arr(:, ind) + call move_alloc(tmp, arr) + + return + end subroutine swiftest_util_sort_rearrange_arr_DPvec + + + pure module subroutine swiftest_util_sort_rearrange_arr_I4B(arr, ind, n) + !! author: David A. Minton + !! + !! Rearrange a single array of integers in-place from an index list. + implicit none + ! Arguments + integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Destination array + integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against + integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange + ! Internals + integer(I4B), dimension(:), allocatable :: tmp !! Temporary copy of array used during rearrange operation + + if (.not. allocated(arr) .or. n <= 0) return + allocate(tmp, mold=arr) + tmp(1:n) = arr(ind) + call move_alloc(tmp, arr) + + return + end subroutine swiftest_util_sort_rearrange_arr_I4B + + pure module subroutine swiftest_util_sort_rearrange_arr_I4B_I8Bind(arr, ind, n) + !! author: David A. Minton + !! + !! Rearrange a single array of integers in-place from an index list. + implicit none + ! Arguments + integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Destination array + integer(I8B), dimension(:), intent(in) :: ind !! Index to rearrange against + integer(I8B), intent(in) :: n !! Number of elements in arr and ind to rearrange + ! Internals + integer(I4B), dimension(:), allocatable :: tmp !! Temporary copy of array used during rearrange operation + + if (.not. allocated(arr) .or. n <= 0_I8B) return + allocate(tmp, mold=arr) + tmp(1:n) = arr(ind) + call move_alloc(tmp, arr) + + return + end subroutine swiftest_util_sort_rearrange_arr_I4B_I8Bind + + + pure module subroutine swiftest_util_sort_rearrange_arr_logical(arr, ind, n) + !! author: David A. Minton + !! + !! Rearrange a single array of logicals in-place from an index list. + implicit none + ! Arguments + logical, dimension(:), allocatable, intent(inout) :: arr !! Destination array + integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against + integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange + ! Internals + logical, dimension(:), allocatable :: tmp !! Temporary copy of array used during rearrange operation + + if (.not. allocated(arr) .or. n <= 0) return + allocate(tmp, mold=arr) + tmp(1:n) = arr(ind) + call move_alloc(tmp, arr) + + return + end subroutine swiftest_util_sort_rearrange_arr_logical + + + pure module subroutine swiftest_util_sort_rearrange_arr_logical_I8Bind(arr, ind, n) + !! author: David A. Minton + !! + !! Rearrange a single array of logicals in-place from an index list. + implicit none + ! Arguments + logical, dimension(:), allocatable, intent(inout) :: arr !! Destination array + integer(I8B), dimension(:), intent(in) :: ind !! Index to rearrange against + integer(I8B), intent(in) :: n !! Number of elements in arr and ind to rearrange + ! Internals + logical, dimension(:), allocatable :: tmp !! Temporary copy of array used during rearrange operation + + if (.not. allocated(arr) .or. n <= 0) return + allocate(tmp, mold=arr) + tmp(1:n) = arr(ind) + call move_alloc(tmp, arr) + + return + end subroutine swiftest_util_sort_rearrange_arr_logical_I8Bind + + + module subroutine swiftest_util_sort_rearrange_arr_info(arr, ind, n) + !! author: David A. Minton + !! + !! Rearrange a single array of particle information type in-place from an index list. + implicit none + ! Arguments + type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: arr !! Destination array + integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against + integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange + ! Internals + type(swiftest_particle_info), dimension(:), allocatable :: tmp !! Temporary copy of array used during rearrange operation + + if (.not. allocated(arr) .or. n <= 0) return + allocate(tmp, mold=arr) + + call util_copy_particle_info_arr(arr, tmp, ind) + call move_alloc(tmp, arr) + + return + end subroutine swiftest_util_sort_rearrange_arr_info + + + module subroutine swiftest_util_sort_rearrange_pl(self, ind) + !! author: David A. Minton + !! + !! Rearrange Swiftest massive body structure in-place from an index list. + !! This is a helper utility used to make polymorphic sorting work on Swiftest structures. + implicit none + class(swiftest_pl), intent(inout) :: self !! Swiftest 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) + + associate(pl => self, npl => self%nbody) + call util_sort_rearrange(pl%mass, ind, npl) + call util_sort_rearrange(pl%Gmass, ind, npl) + call util_sort_rearrange(pl%rhill, ind, npl) + call util_sort_rearrange(pl%renc, ind, npl) + call util_sort_rearrange(pl%radius, ind, npl) + call util_sort_rearrange(pl%density, ind, npl) + call util_sort_rearrange(pl%rbeg, ind, npl) + call util_sort_rearrange(pl%vbeg, ind, npl) + call util_sort_rearrange(pl%Ip, ind, npl) + call util_sort_rearrange(pl%rot, ind, npl) + call util_sort_rearrange(pl%k2, ind, npl) + call util_sort_rearrange(pl%Q, ind, npl) + call util_sort_rearrange(pl%tlag, ind, npl) + call util_sort_rearrange(pl%kin, ind, npl) + call util_sort_rearrange(pl%lmtiny, ind, npl) + call util_sort_rearrange(pl%nplenc, ind, npl) + call util_sort_rearrange(pl%ntpenc, ind, npl) + + if (allocated(pl%k_plpl)) deallocate(pl%k_plpl) + + call util_sort_rearrange_body(pl, ind) + end associate + + return + end subroutine swiftest_util_sort_rearrange_pl + + + module subroutine swiftest_util_sort_rearrange_tp(self, ind) + !! author: David A. Minton + !! + !! Rearrange Swiftest massive body structure in-place from an index list. + !! This is a helper utility used to make polymorphic sorting work on Swiftest structures. + implicit none + ! Arguments + class(swiftest_tp), intent(inout) :: self !! Swiftest test particle 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) + + associate(tp => self, ntp => self%nbody) + call util_sort_rearrange(tp%nplenc, ind, ntp) + + if (allocated(tp%k_pltp)) deallocate(tp%k_pltp) + + call util_sort_rearrange_body(tp, ind) + end associate + + return + end subroutine swiftest_util_sort_rearrange_tp + + + module subroutine swiftest_util_spill_arr_char_string(keeps, discards, lspill_list, ldestructive) + !! author: David A. Minton + !! + !! Performs a spill operation on a single array of type character strings + !! This is the inverse of a spill operation + implicit none + ! Arguments + character(len=STRMAX), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + character(len=STRMAX), dimension(:), allocatable, intent(inout) :: discards !! Array of discards + 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 + ! Internals + integer(I4B) :: nspill, nkeep, nlist + character(len=STRMAX), dimension(:), allocatable :: tmp !! Array of values to keep + + nkeep = count(.not.lspill_list(:)) + nspill = count(lspill_list(:)) + nlist = size(lspill_list(:)) + + if (.not.allocated(keeps) .or. nspill == 0) return + if (.not.allocated(discards)) then + allocate(discards(nspill)) + else if (size(discards) /= nspill) then + deallocate(discards) + allocate(discards(nspill)) + end if + + discards(:) = pack(keeps(1:nlist), lspill_list(1:nlist)) + if (ldestructive) then + if (nkeep > 0) then + allocate(tmp(nkeep)) + tmp(:) = pack(keeps(1:nlist), .not. lspill_list(1:nlist)) + call move_alloc(tmp, keeps) + else + deallocate(keeps) + end if + end if + + return + end subroutine swiftest_util_spill_arr_char_string + + + module subroutine swiftest_util_spill_arr_DP(keeps, discards, lspill_list, ldestructive) + !! author: David A. Minton + !! + !! Performs a spill operation on a single array of type DP + !! This is the inverse of a spill operation + implicit none + ! Arguments + real(DP), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + real(DP), 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 + ! Internals + integer(I4B) :: nspill, nkeep, nlist + real(DP), dimension(:), allocatable :: tmp !! Array of values to keep + + nkeep = count(.not.lspill_list(:)) + nspill = count(lspill_list(:)) + nlist = size(lspill_list(:)) + + if (.not.allocated(keeps) .or. nspill == 0) return + if (.not.allocated(discards)) then + allocate(discards(nspill)) + else if (size(discards) /= nspill) then + deallocate(discards) + allocate(discards(nspill)) + end if + + discards(:) = pack(keeps(1:nlist), lspill_list(1:nlist)) + if (ldestructive) then + if (nkeep > 0) then + allocate(tmp(nkeep)) + tmp(:) = pack(keeps(1:nlist), .not. lspill_list(1:nlist)) + call move_alloc(tmp, keeps) + else + deallocate(keeps) + end if + end if + + return + end subroutine swiftest_util_spill_arr_DP + + + module subroutine swiftest_util_spill_arr_DPvec(keeps, discards, lspill_list, ldestructive) + !! author: David A. Minton + !! + !! Performs a spill operation on a single array of DP vectors with shape (NDIM, n) + !! This is the inverse of a spill operation + implicit none + ! Arguments + real(DP), dimension(:,:), allocatable, intent(inout) :: keeps !! Array of values to keep + real(DP), dimension(:,:), allocatable, intent(inout) :: discards !! Array discards + 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 + ! Internals + integer(I4B) :: i, nspill, nkeep, nlist + real(DP), dimension(:,:), allocatable :: tmp !! Array of values to keep + + nkeep = count(.not.lspill_list(:)) + nspill = count(lspill_list(:)) + nlist = size(lspill_list(:)) + + if (.not.allocated(keeps) .or. nspill == 0) return + if (.not.allocated(discards)) then + allocate(discards(NDIM, nspill)) + else if (size(discards, dim=2) /= nspill) then + deallocate(discards) + allocate(discards(NDIM, nspill)) + end if + + do i = 1, NDIM + discards(i,:) = pack(keeps(i,1:nlist), lspill_list(1:nlist)) + end do + if (ldestructive) then + if (nkeep > 0) then + allocate(tmp(NDIM, nkeep)) + do i = 1, NDIM + tmp(i, :) = pack(keeps(i, 1:nlist), .not. lspill_list(1:nlist)) + end do + call move_alloc(tmp, keeps) + else + deallocate(keeps) + end if + end if + + return + end subroutine swiftest_util_spill_arr_DPvec + + + module subroutine swiftest_util_spill_arr_I4B(keeps, discards, lspill_list, ldestructive) + !! author: David A. Minton + !! + !! Performs a spill operation on a single array of type I4B + !! This is the inverse of a spill operation + implicit none + ! Arguments + integer(I4B), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + integer(I4B), dimension(:), allocatable, intent(inout) :: discards !! Array of discards + 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 + ! Internals + integer(I4B) :: nspill, nkeep, nlist + integer(I4B), dimension(:), allocatable :: tmp !! Array of values to keep + + nkeep = count(.not.lspill_list(:)) + nspill = count(lspill_list(:)) + nlist = size(lspill_list(:)) + + if (.not.allocated(keeps) .or. nspill == 0) return + if (.not.allocated(discards)) then + allocate(discards(nspill)) + else if (size(discards) /= nspill) then + deallocate(discards) + allocate(discards(nspill)) + end if + + discards(:) = pack(keeps(1:nlist), lspill_list(1:nlist)) + if (ldestructive) then + if (nkeep > 0) then + allocate(tmp(nkeep)) + tmp(:) = pack(keeps(1:nlist), .not. lspill_list(1:nlist)) + call move_alloc(tmp, keeps) + else + deallocate(keeps) + end if + end if + + return + end subroutine swiftest_util_spill_arr_I4B + + + module subroutine swiftest_util_spill_arr_I8B(keeps, discards, lspill_list, ldestructive) + !! author: David A. Minton + !! + !! Performs a spill operation on a single array of type I4B + !! This is the inverse of a spill operation + implicit none + ! Arguments + integer(I8B), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + integer(I8B), dimension(:), allocatable, intent(inout) :: discards !! Array of discards + 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 + ! Internals + integer(I4B) :: nspill, nkeep, nlist + integer(I8B), dimension(:), allocatable :: tmp !! Array of values to keep + + nkeep = count(.not.lspill_list(:)) + nspill = count(lspill_list(:)) + nlist = size(lspill_list(:)) + + if (.not.allocated(keeps) .or. nspill == 0) return + if (.not.allocated(discards)) then + allocate(discards(nspill)) + else if (size(discards) /= nspill) then + deallocate(discards) + allocate(discards(nspill)) + end if + + discards(:) = pack(keeps(1:nlist), lspill_list(1:nlist)) + if (ldestructive) then + if (nkeep > 0) then + allocate(tmp(nkeep)) + tmp(:) = pack(keeps(1:nlist), .not. lspill_list(1:nlist)) + call move_alloc(tmp, keeps) + else + deallocate(keeps) + end if + end if + + return + end subroutine swiftest_util_spill_arr_I8B + + + module subroutine swiftest_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(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + type(swiftest_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 + ! Internals + integer(I4B) :: i, nspill, nkeep, nlist + integer(I4B), dimension(:), allocatable :: idx + type(swiftest_particle_info), dimension(:), allocatable :: tmp + + nkeep = count(.not.lspill_list(:)) + nspill = count(lspill_list(:)) + nlist = size(lspill_list(:)) + + if (.not.allocated(keeps) .or. nspill == 0) return + if (.not.allocated(discards)) then + allocate(discards(nspill)) + else if (size(discards) /= nspill) then + deallocate(discards) + allocate(discards(nspill)) + end if + + allocate(idx(nspill)) + idx(:) = pack([(i, i = 1, nlist)], lspill_list) + call util_copy_particle_info_arr(keeps, discards, idx) + if (ldestructive) then + if (nkeep > 0) then + deallocate(idx) + allocate(idx(nkeep)) + allocate(tmp(nkeep)) + idx(:) = pack([(i, i = 1, nlist)], .not. lspill_list) + call util_copy_particle_info_arr(keeps, tmp, idx) + call move_alloc(tmp, keeps) + else + deallocate(keeps) + end if + end if + + return + end subroutine swiftest_util_spill_arr_info + + + module subroutine swiftest_util_spill_arr_logical(keeps, discards, lspill_list, ldestructive) + !! author: David A. Minton + !! + !! Performs a spill operation on a single array of logicals + !! This is the inverse of a spill operation + implicit none + ! Arguments + logical, dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep + logical, dimension(:), allocatable, intent(inout) :: discards !! Array of discards + 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 no + ! Internals + integer(I4B) :: nspill, nkeep, nlist + logical, dimension(:), allocatable :: tmp !! Array of values to keep + + nkeep = count(.not.lspill_list(:)) + nspill = count(lspill_list(:)) + nlist = size(lspill_list(:)) + + if (.not.allocated(keeps) .or. nspill == 0) return + if (.not.allocated(discards)) then + allocate(discards(nspill)) + else if (size(discards) /= nspill) then + deallocate(discards) + allocate(discards(nspill)) + end if + + discards(:) = pack(keeps(1:nlist), lspill_list(1:nlist)) + if (ldestructive) then + if (nkeep > 0) then + allocate(tmp(nkeep)) + tmp(:) = pack(keeps(1:nlist), .not. lspill_list(1:nlist)) + call move_alloc(tmp, keeps) + else + deallocate(keeps) + end if + end if + + return + end subroutine swiftest_util_spill_arr_logical + + + module subroutine swiftest_util_spill_body(self, discards, lspill_list, ldestructive) + !! author: David A. Minton + !! + !! Move spilled (discarded) Swiftest generic particle structure from active list to discard list + !! Adapted from David E. Kaufmann's Swifter routine whm_discard_spill.f90 + implicit none + ! Arguments + class(swiftest_body), intent(inout) :: self !! Swiftest generic 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 body by removing the discard list + ! Internals + integer(I4B) :: nbody_old + + ! 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) + + call util_spill(keeps%id, discards%id, lspill_list, ldestructive) + call util_spill(keeps%info, discards%info, lspill_list, ldestructive) + call util_spill(keeps%lmask, discards%lmask, lspill_list, ldestructive) + call util_spill(keeps%status, discards%status, lspill_list, ldestructive) + call util_spill(keeps%ldiscard, discards%ldiscard, lspill_list, ldestructive) + call util_spill(keeps%lcollision, discards%lcollision, lspill_list, ldestructive) + call util_spill(keeps%lencounter, discards%lencounter, lspill_list, ldestructive) + call util_spill(keeps%mu, discards%mu, lspill_list, ldestructive) + call util_spill(keeps%rh, discards%rh, lspill_list, ldestructive) + call util_spill(keeps%vh, discards%vh, lspill_list, ldestructive) + call util_spill(keeps%rb, discards%rb, lspill_list, ldestructive) + call util_spill(keeps%vb, discards%vb, lspill_list, ldestructive) + call util_spill(keeps%ah, discards%ah, lspill_list, ldestructive) + call util_spill(keeps%aobl, discards%aobl, lspill_list, ldestructive) + call util_spill(keeps%agr, discards%agr, lspill_list, ldestructive) + call util_spill(keeps%atide, discards%atide, lspill_list, ldestructive) + call util_spill(keeps%ir3h, discards%ir3h, 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) + call util_spill(keeps%a, discards%a, lspill_list, ldestructive) + call util_spill(keeps%e, discards%e, lspill_list, ldestructive) + call util_spill(keeps%inc, discards%inc, lspill_list, ldestructive) + call util_spill(keeps%capom, discards%capom, lspill_list, ldestructive) + call util_spill(keeps%omega, discards%omega, lspill_list, ldestructive) + call util_spill(keeps%capm, discards%capm, lspill_list, ldestructive) + + nbody_old = keeps%nbody + + ! This is the base class, so will be the last to be called in the cascade. + ! Therefore we need to set the nbody values for both the keeps and discareds + discards%nbody = count(lspill_list(1:nbody_old)) + if (ldestructive) keeps%nbody = nbody_old- discards%nbody + end associate + + return + end subroutine swiftest_util_spill_body + + + module subroutine swiftest_util_spill_pl(self, discards, lspill_list, ldestructive) + !! author: David A. Minton + !! + !! Move spilled (discarded) Swiftest massive body structure from active list to discard list + !! Adapted from David E. Kaufmann's Swifter routine whm_discard_spill.f90 + implicit none + ! Arguments + class(swiftest_pl), intent(inout) :: self !! Swiftest 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 body by removing the discard list + + associate(keeps => self) + select type (discards) ! The standard requires us to select the type of both arguments in order to access all the components + class is (swiftest_pl) + !> Spill components specific to the massive body class + call util_spill(keeps%mass, discards%mass, lspill_list, ldestructive) + call util_spill(keeps%Gmass, discards%Gmass, lspill_list, ldestructive) + call util_spill(keeps%rhill, discards%rhill, lspill_list, ldestructive) + call util_spill(keeps%renc, discards%renc, lspill_list, ldestructive) + call util_spill(keeps%radius, discards%radius, lspill_list, ldestructive) + call util_spill(keeps%density, discards%density, lspill_list, ldestructive) + call util_spill(keeps%rbeg, discards%rbeg, lspill_list, ldestructive) + call util_spill(keeps%rend, discards%rend, lspill_list, ldestructive) + call util_spill(keeps%vbeg, discards%vbeg, lspill_list, ldestructive) + call util_spill(keeps%Ip, discards%Ip, lspill_list, ldestructive) + call util_spill(keeps%rot, discards%rot, lspill_list, ldestructive) + call util_spill(keeps%k2, discards%k2, lspill_list, ldestructive) + call util_spill(keeps%Q, discards%Q, lspill_list, ldestructive) + call util_spill(keeps%tlag, discards%tlag, lspill_list, ldestructive) + call util_spill(keeps%kin, discards%kin, lspill_list, ldestructive) + call util_spill(keeps%lmtiny, discards%lmtiny, lspill_list, ldestructive) + call util_spill(keeps%nplenc, discards%nplenc, lspill_list, ldestructive) + call util_spill(keeps%ntpenc, discards%ntpenc, lspill_list, ldestructive) + + if (ldestructive .and. allocated(keeps%k_plpl)) deallocate(keeps%k_plpl) + + call util_spill_body(keeps, discards, lspill_list, ldestructive) + class default + write(*,*) 'Error! spill method called for incompatible return type on swiftest_pl' + end select + end associate + + return + end subroutine swiftest_util_spill_pl + + + module subroutine swiftest_util_spill_tp(self, discards, lspill_list, ldestructive) + !! author: David A. Minton + !! + !! Move spilled (discarded) Swiftest 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(swiftest_tp), intent(inout) :: self !! Swiftest 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 discardse + logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter body by removing the discard list + + associate(keeps => self, ntp => self%nbody) + select type(discards) + class is (swiftest_tp) + !> Spill components specific to the test particle class + call util_spill(keeps%nplenc, discards%nplenc, lspill_list, ldestructive) + call util_spill_body(keeps, discards, lspill_list, ldestructive) + class default + write(*,*) 'Error! spill method called for incompatible return type on swiftest_tp' + end select + end associate + + return + end subroutine swiftest_util_spill_tp + + + module subroutine swiftest_util_unique_DP(input_array, output_array, index_map) + !! author: David A. Minton + !! + !! Takes an input unsorted integer array and returns a new array of sorted, unique values (DP version) + implicit none + ! Arguments + real(DP), dimension(:), intent(in) :: input_array !! Unsorted input array + real(DP), dimension(:), allocatable, intent(out) :: output_array !! Sorted array of unique values + integer(I4B), dimension(:), allocatable, intent(out) :: index_map !! An array of the same size as input_array that such that any for any index i, output_array(index_map(i)) = input_array(i) + ! Internals + real(DP), dimension(:), allocatable :: unique_array + integer(I4B) :: n + real(DP) :: lo, hi + + allocate(unique_array, mold=input_array) + allocate(index_map(size(input_array))) + lo = minval(input_array) - 1 + hi = maxval(input_array) + + n = 0 + do + n = n + 1 + lo = minval(input_array(:), mask=input_array(:) > lo) + unique_array(n) = lo + where(input_array(:) == lo) index_map(:) = n + if (lo >= hi) exit + enddo + allocate(output_array(n), source=unique_array(1:n)) + + return + end subroutine swiftest_util_unique_DP + + + module subroutine swiftest_util_unique_I4B(input_array, output_array, index_map) + !! author: David A. Minton + !! + !! Takes an input unsorted integer array and returns a new array of sorted, unique values (I4B version) + implicit none + ! Arguments + integer(I4B), dimension(:), intent(in) :: input_array !! Unsorted input array + integer(I4B), dimension(:), allocatable, intent(out) :: output_array !! Sorted array of unique values + integer(I4B), dimension(:), allocatable, intent(out) :: index_map !! An array of the same size as input_array that such that any for any index i, output_array(index_map(i)) = input_array(i) + ! Internals + integer(I4B), dimension(:), allocatable :: unique_array + integer(I4B) :: n, lo, hi + + allocate(unique_array, mold=input_array) + allocate(index_map, mold=input_array) + lo = minval(input_array) - 1 + hi = maxval(input_array) + + n = 0 + do + n = n + 1 + lo = minval(input_array(:), mask=input_array(:) > lo) + unique_array(n) = lo + where(input_array(:) == lo) index_map(:) = n + if (lo >= hi) exit + enddo + allocate(output_array(n), source=unique_array(1:n)) + + return + end subroutine swiftest_util_unique_I4B + + + module subroutine swiftest_util_valid_id_system(self, param) + !! author: David A. Minton + !! + !! Validate massive body and test particle ids + !! subroutine swiftest_causes program to exit with error if any ids are not unique + !! + !! Adapted from David E. Kaufmann's Swifter routine: util_valid.f90 + implicit none + ! Arguments + class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters + ! Internals + integer(I4B) :: i + integer(I4B), dimension(:), allocatable :: idarr + + associate(cb => self%cb, pl => self%pl, npl => self%pl%nbody, tp => self%tp, ntp => self%tp%nbody) + allocate(idarr(1+npl+ntp)) + idarr(1) = cb%id + do i = 1, npl + idarr(1+i) = pl%id(i) + end do + do i = 1, ntp + idarr(1+npl+i) = tp%id(i) + end do + call util_sort(idarr) + do i = 1, npl + ntp + if (idarr(i) == idarr(i+1)) then + write(*, *) "Swiftest error:" + write(*, *) " more than one body/particle has id = ", idarr(i) + call util_exit(FAILURE) + end if + end do + param%maxid = max(param%maxid, maxval(idarr)) + end associate + + return + end subroutine swiftest_util_valid_id_system + + + module subroutine swiftest_util_version() + !! author: David A. Minton + !! + !! Print program version information to terminale + !! + !! Adapted from David E. Kaufmann's Swifter routine: util_version.f90 + implicit none + write(*, 200) VERSION_NUMBER + 200 format(/, "************* Swiftest: Version ", f3.1, " *************", //, & + "Based off of Swifter:", //, & + "Authors:", //, & + " The Purdue University Swiftest Development team ", /, & + " Lead by David A. Minton ", /, & + " Single loop blocking by Jacob R. Elliott", /, & + " Fragmentation by Carlisle A. Wishard and", //, & + " Jennifer L. L. Poutplin ", //, & + "Please address comments and questions to:", //, & + " David A. Minton", /, & + " Department Earth, Atmospheric, & Planetary Sciences ",/, & + " Purdue University", /, & + " 550 Stadium Mall Drive", /, & + " West Lafayette, Indiana 47907", /, & + " 765-250-8034 ", /, & + " daminton@purdue.edu", /, & + "Special thanks to Hal Levison and Martin Duncan for the original",/,& + "SWIFTER and SWIFT codes that made this possible.", //, & + "************************************************", /) + + + 100 FORMAT(/, "************* SWIFTER: Version ", F3.1, " *************", //, & + "Authors:", //, & + " Martin Duncan: Queen's University", /, & + " Hal Levison : Southwest Research Institute", //, & + "Please address comments and questions to:", //, & + " Hal Levison or David Kaufmann", /, & + " Department of Space Studies", /, & + " Southwest Research Institute", /, & + " 1050 Walnut Street, Suite 400", /, & + " Boulder, Colorado 80302", /, & + " 303-546-0290 (HFL), 720-240-0119 (DEK)", /, & + " 303-546-9687 (fax)", /, & + " hal@gort.boulder.swri.edu (HFL)", /, & + " kaufmann@boulder.swri.edu (DEK)", //, & + "************************************************", /) + + return + end subroutine swiftest_util_version + +end submodule s_util \ No newline at end of file diff --git a/src/symba/symba_collision.f90 b/src/symba/symba_collision.f90 deleted file mode 100644 index 0c0150997..000000000 --- a/src/symba/symba_collision.f90 +++ /dev/null @@ -1,1081 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule (symba_classes) s_symba_collision - use swiftest - -contains - - module function symba_collision_casedisruption(system, param, t) result(status) - !! author: Jennifer L.L. Pouplin, Carlisle A. Wishard, and David A. Minton - !! - !! Create the fragments resulting from a non-catastrophic disruption collision - !! - implicit none - ! Arguments - class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object - class(symba_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions - real(DP), intent(in) :: t !! Time of collision - ! Result - integer(I4B) :: status !! Status flag assigned to this outcome - ! Internals - integer(I4B) :: i, ibiggest, nfrag - logical :: lfailure - character(len=STRMAX) :: message - real(DP) :: dpe - - associate(collision_system => system%collision_system, impactors => system%collision_system%impactors, fragments => system%collision_system%fragments) - select case(impactors%regime) - case(COLLRESOLVE_REGIME_DISRUPTION) - message = "Disruption between" - case(COLLRESOLVE_REGIME_SUPERCATASTROPHIC) - message = "Supercatastrophic disruption between" - end select - call symba_collision_collider_message(system%pl, impactors%idx, message) - call io_log_one_message(FRAGGLE_LOG_OUT, message) - - ! Collisional fragments will be uniformly distributed around the pre-impact barycenter - call collision_system%set_mass_dist(param) - - ! Generate the position and velocity distributions of the fragments - call collision_system%generate_fragments(system, param, lfailure) - - dpe = collision_system%pe(2) - collision_system%pe(1) - system%Ecollisions = system%Ecollisions - dpe - system%Euntracked = system%Euntracked + dpe - - if (lfailure) then - call io_log_one_message(FRAGGLE_LOG_OUT, "No fragment solution found, so treat as a pure hit-and-run") - status = ACTIVE - nfrag = 0 - select type(pl => system%pl) - class is (symba_pl) - pl%status(impactors%idx(:)) = status - pl%ldiscard(impactors%idx(:)) = .false. - pl%lcollision(impactors%idx(:)) = .false. - end select - allocate(collision_system%after%pl, source=collision_system%before%pl) ! Be sure to save the pl so that snapshots still work - else - ! Populate the list of new bodies - nfrag = fragments%nbody - write(message, *) nfrag - call io_log_one_message(FRAGGLE_LOG_OUT, "Generating " // trim(adjustl(message)) // " fragments") - select case(impactors%regime) - case(COLLRESOLVE_REGIME_DISRUPTION) - status = DISRUPTION - ibiggest = impactors%idx(maxloc(system%pl%Gmass(impactors%idx(:)), dim=1)) - fragments%id(1) = system%pl%id(ibiggest) - fragments%id(2:nfrag) = [(i, i = param%maxid + 1, param%maxid + nfrag - 1)] - param%maxid = fragments%id(nfrag) - case(COLLRESOLVE_REGIME_SUPERCATASTROPHIC) - status = SUPERCATASTROPHIC - fragments%id(1:nfrag) = [(i, i = param%maxid + 1, param%maxid + nfrag)] - param%maxid = fragments%id(nfrag) - end select - - call symba_collision_mergeaddsub(system, param, t, status) - end if - end associate - - return - end function symba_collision_casedisruption - - - module function symba_collision_casehitandrun(system, param, t) result(status) - !! author: Jennifer L.L. Pouplin, Carlisle A. Wishard, and David A. Minton - !! - !! Create the fragments resulting from a non-catastrophic hit-and-run collision - !! - implicit none - ! Arguments - class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object - class(symba_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions - real(DP), intent(in) :: t !! Time of collision - ! Result - integer(I4B) :: status !! Status flag assigned to this outcom - ! Internals - integer(I4B) :: i, ibiggest, nfrag, jtarg, jproj - logical :: lpure - character(len=STRMAX) :: message - real(DP) :: dpe - - associate(collision_system => system%collision_system, impactors => system%collision_system%impactors, fragments => system%collision_system%fragments) - message = "Hit and run between" - call symba_collision_collider_message(system%pl, impactors%idx, message) - call io_log_one_message(FRAGGLE_LOG_OUT, trim(adjustl(message))) - - if (impactors%mass(1) > impactors%mass(2)) then - jtarg = 1 - jproj = 2 - else - jtarg = 2 - jproj = 1 - end if - - if (impactors%mass_dist(2) > 0.9_DP * impactors%mass(jproj)) then ! Pure hit and run, so we'll just keep the two bodies untouched - call io_log_one_message(FRAGGLE_LOG_OUT, "Pure hit and run. No new fragments generated.") - nfrag = 0 - lpure = .true. - else ! Imperfect hit and run, so we'll keep the largest body and destroy the other - lpure = .false. - call collision_system%set_mass_dist(param) - - ! Generate the position and velocity distributions of the fragments - call collision_system%generate_fragments(system, param, lpure) - - dpe = collision_system%pe(2) - collision_system%pe(1) - system%Ecollisions = system%Ecollisions - dpe - system%Euntracked = system%Euntracked + dpe - - if (lpure) then - call io_log_one_message(FRAGGLE_LOG_OUT, "Should have been a pure hit and run instead") - nfrag = 0 - else - nfrag = fragments%nbody - write(message, *) nfrag - call io_log_one_message(FRAGGLE_LOG_OUT, "Generating " // trim(adjustl(message)) // " fragments") - end if - end if - if (lpure) then ! Reset these bodies back to being active so that nothing further is done to them - status = HIT_AND_RUN_PURE - select type(pl => system%pl) - class is (symba_pl) - pl%status(impactors%idx(:)) = ACTIVE - pl%ldiscard(impactors%idx(:)) = .false. - pl%lcollision(impactors%idx(:)) = .false. - end select - allocate(collision_system%after%pl, source=collision_system%before%pl) ! Be sure to save the pl so that snapshots still work - else - ibiggest = impactors%idx(maxloc(system%pl%Gmass(impactors%idx(:)), dim=1)) - fragments%id(1) = system%pl%id(ibiggest) - fragments%id(2:nfrag) = [(i, i = param%maxid + 1, param%maxid + nfrag - 1)] - param%maxid = fragments%id(nfrag) - status = HIT_AND_RUN_DISRUPT - call symba_collision_mergeaddsub(system, param, t, status) - end if - - end associate - - return - end function symba_collision_casehitandrun - - - module function symba_collision_casemerge(system, param, t) result(status) - !! author: Jennifer L.L. Pouplin, Carlisle A. Wishard, and David A. Minton - !! - !! Merge massive bodies. - !! - !! Adapted from David E. Kaufmann's Swifter routines symba_merge_pl.f90 and symba_discard_merge_pl.f90 - !! - !! Adapted from Hal Levison's Swift routines symba5_merge.f and discard_mass_merge.f - implicit none - ! Arguments - class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object - class(symba_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions - real(DP), intent(in) :: t !! Time of collision - ! Result - integer(I4B) :: status !! Status flag assigned to this outcome - ! Internals - integer(I4B) :: i, j, k, ibiggest - real(DP), dimension(NDIM) :: Lspin_new - real(DP) :: dpe - character(len=STRMAX) :: message - - associate(collision_system => system%collision_system, impactors => system%collision_system%impactors, fragments => system%collision_system%fragments) - message = "Merging" - call symba_collision_collider_message(system%pl, impactors%idx, message) - call io_log_one_message(FRAGGLE_LOG_OUT, message) - - select type(pl => system%pl) - class is (symba_pl) - - call collision_system%set_mass_dist(param) - - ! Calculate the initial energy of the system without the collisional family - call collision_system%get_energy_and_momentum(system, param, lbefore=.true.) - - ibiggest = impactors%idx(maxloc(pl%Gmass(impactors%idx(:)), dim=1)) - fragments%id(1) = pl%id(ibiggest) - fragments%rb(:,1) = impactors%rbcom(:) - fragments%vb(:,1) = impactors%vbcom(:) - - if (param%lrotation) then - ! Conserve angular momentum by putting pre-impact orbital momentum into spin of the new body - Lspin_new(:) = impactors%Lorbit(:,1) + impactors%Lorbit(:,2) + impactors%Lspin(:,1) + impactors%Lspin(:,2) - - ! Assume prinicpal axis rotation on 3rd Ip axis - fragments%rot(:,1) = Lspin_new(:) / (fragments%Ip(3,1) * fragments%mass(1) * fragments%radius(1)**2) - else ! If spin is not enabled, we will consider the lost pre-collision angular momentum as "escaped" and add it to our bookkeeping variable - system%Lescape(:) = system%Lescape(:) + impactors%Lorbit(:,1) + impactors%Lorbit(:,2) - end if - - ! Keep track of the component of potential energy due to the pre-impact impactors%idx for book-keeping - ! Get the energy of the system after the collision - call collision_system%get_energy_and_momentum(system, param, lbefore=.false.) - dpe = collision_system%pe(2) - collision_system%pe(1) - system%Ecollisions = system%Ecollisions - dpe - system%Euntracked = system%Euntracked + dpe - - - ! Update any encounter lists that have the removed bodies in them so that they instead point to the new - do k = 1, system%plplenc_list%nenc - do j = 1, impactors%ncoll - i = impactors%idx(j) - if (i == ibiggest) cycle - if (system%plplenc_list%id1(k) == pl%id(i)) then - system%plplenc_list%id1(k) = pl%id(ibiggest) - system%plplenc_list%index1(k) = i - end if - if (system%plplenc_list%id2(k) == pl%id(i)) then - system%plplenc_list%id2(k) = pl%id(ibiggest) - system%plplenc_list%index2(k) = i - end if - if (system%plplenc_list%id1(k) == system%plplenc_list%id2(k)) system%plplenc_list%status(k) = INACTIVE - end do - end do - - status = MERGED - - call symba_collision_mergeaddsub(system, param, t, status) - - end select - end associate - return - end function symba_collision_casemerge - - - subroutine symba_collision_collider_message(pl, collidx, collider_message) - !! author: David A. Minton - !! - !! Prints a nicely formatted message about which bodies collided, including their names and ids. - !! This subroutine appends the body names and ids to an input message. - implicit none - ! Arguments - class(swiftest_pl), intent(in) :: pl !! Swiftest massive body object - integer(I4B), dimension(:), intent(in) :: collidx !! Index of collisional impactors%idx members - character(*), intent(inout) :: collider_message !! The message to print to the screen. - ! Internals - integer(I4B) :: i, n - character(len=STRMAX) :: idstr - - n = size(collidx) - if (n == 0) return - - do i = 1, n - if (i > 1) collider_message = trim(adjustl(collider_message)) // " and " - collider_message = " " // trim(adjustl(collider_message)) // " " // trim(adjustl(pl%info(collidx(i))%name)) - write(idstr, '(I10)') pl%id(collidx(i)) - collider_message = trim(adjustl(collider_message)) // " (" // trim(adjustl(idstr)) // ") " - end do - - return - end subroutine symba_collision_collider_message - - - module subroutine symba_collision_check_encounter(self, system, param, t, dt, irec, lany_collision) - !! author: David A. Minton - !! - !! Check for merger between massive bodies and test particles in SyMBA - !! - !! Adapted from David E. Kaufmann's Swifter routine symba_merge.f90 and symba_merge_tp.f90 - !! - !! Adapted from Hal Levison's Swift routine symba5_merge.f - implicit none - ! Arguments - class(symba_encounter), intent(inout) :: self !! SyMBA pl-tp encounter list object - class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - real(DP), intent(in) :: t !! current time - real(DP), intent(in) :: dt !! step size - integer(I4B), intent(in) :: irec !! Current recursion level - logical, intent(out) :: lany_collision !! Returns true if cany pair of encounters resulted in a collision - ! Internals - logical, dimension(:), allocatable :: lcollision, lmask - real(DP), dimension(NDIM) :: xr, vr - integer(I4B) :: i, j, k, nenc - real(DP) :: rlim, Gmtot - logical :: isplpl, lany_closest - character(len=STRMAX) :: timestr, idstri, idstrj, message - class(symba_encounter), allocatable :: tmp - - lany_collision = .false. - if (self%nenc == 0) return - - select type(self) - class is (symba_plplenc) - isplpl = .true. - class default - isplpl = .false. - end select - - select type(pl => system%pl) - class is (symba_pl) - select type(tp => system%tp) - class is (symba_tp) - select type (param) - class is (symba_parameters) - nenc = self%nenc - allocate(lmask(nenc)) - lmask(:) = ((self%status(1:nenc) == ACTIVE) .and. (pl%levelg(self%index1(1:nenc)) >= irec)) - if (isplpl) then - lmask(:) = lmask(:) .and. (pl%levelg(self%index2(1:nenc)) >= irec) - else - lmask(:) = lmask(:) .and. (tp%levelg(self%index2(1:nenc)) >= irec) - end if - if (.not.any(lmask(:))) return - - allocate(lcollision(nenc)) - lcollision(:) = .false. - self%lclosest(:) = .false. - - if (isplpl) then - do concurrent(k = 1:nenc, lmask(k)) - i = self%index1(k) - j = self%index2(k) - xr(:) = pl%rh(:, i) - pl%rh(:, j) - vr(:) = pl%vb(:, i) - pl%vb(:, j) - rlim = pl%radius(i) + pl%radius(j) - Gmtot = pl%Gmass(i) + pl%Gmass(j) - call symba_collision_check_one(xr(1), xr(2), xr(3), vr(1), vr(2), vr(3), Gmtot, rlim, dt, self%lvdotr(k), lcollision(k), self%lclosest(k)) - end do - else - do concurrent(k = 1:nenc, lmask(k)) - i = self%index1(k) - j = self%index2(k) - xr(:) = pl%rh(:, i) - tp%rh(:, j) - vr(:) = pl%vb(:, i) - tp%vb(:, j) - call symba_collision_check_one(xr(1), xr(2), xr(3), vr(1), vr(2), vr(3), pl%Gmass(i), pl%radius(i), dt, self%lvdotr(k), lcollision(k), self%lclosest(k)) - end do - end if - - lany_collision = any(lcollision(:)) - lany_closest = (param%lenc_save_closest .and. any(self%lclosest(:))) - - - if (lany_collision .or. lany_closest) then - call pl%rh2rb(system%cb) ! Update the central body barycenteric position vector to get us out of DH and into bary - do k = 1, nenc - if (.not.lcollision(k) .and. .not. self%lclosest(k)) cycle - i = self%index1(k) - j = self%index2(k) - self%r1(:,k) = pl%rh(:,i) + system%cb%rb(:) - self%v1(:,k) = pl%vb(:,i) - if (lcollision(k)) then - self%status(k) = COLLISION - self%tcollision(k) = t - end if - if (isplpl) then - self%r2(:,k) = pl%rh(:,j) + system%cb%rb(:) - self%v2(:,k) = pl%vb(:,j) - if (lcollision(k)) then - ! Check to see if either of these bodies has been involved with a collision before, and if so, make this a collider pair - if (pl%lcollision(i) .or. pl%lcollision(j)) call pl%make_impactors([i,j]) - - ! Set the collision flag for these to bodies to true in case they become involved in another collision later in the step - pl%lcollision([i, j]) = .true. - pl%status([i, j]) = COLLISION - call pl%info(i)%set_value(status="COLLISION") - call pl%info(j)%set_value(status="COLLISION") - end if - else - self%r2(:,k) = tp%rh(:,j) + system%cb%rb(:) - self%v2(:,k) = tp%vb(:,j) - if (lcollision(k)) then - tp%status(j) = DISCARDED_PLR - tp%ldiscard(j) = .true. - write(idstri, *) pl%id(i) - write(idstrj, *) tp%id(j) - write(timestr, *) t - call tp%info(j)%set_value(status="DISCARDED_PLR", discard_time=t, discard_rh=tp%rh(:,j), discard_vh=tp%vh(:,j)) - write(message, *) "Particle " // trim(adjustl(tp%info(j)%name)) // " (" // trim(adjustl(idstrj)) // ")" & - // " collided with massive body " // trim(adjustl(pl%info(i)%name)) // " (" // trim(adjustl(idstri)) // ")" & - // " at t = " // trim(adjustl(timestr)) - call io_log_one_message(FRAGGLE_LOG_OUT, message) - end if - end if - end do - - ! Extract the pl-pl or pl-tp encounter list and return the pl-pl or pl-tp collision_list - select type(self) - class is (symba_plplenc) - call self%extract_collisions(system, param) - class is (symba_pltpenc) - allocate(tmp, mold=self) - call self%spill(tmp, lcollision, ldestructive=.true.) ! Remove this encounter pair from the encounter list - end select - end if - - ! Take snapshots of pairs of bodies at close approach (but not collision) if requested - if (lany_closest) call param%encounter_history%take_snapshot(param, system, t, "closest") - - end select - - end select - end select - - return - end subroutine symba_collision_check_encounter - - - pure elemental subroutine symba_collision_check_one(xr, yr, zr, vxr, vyr, vzr, Gmtot, rlim, dt, lvdotr, lcollision, lclosest) - !! author: David A. Minton - !! - !! Check for a merger between a single pair of particles - !! - !! Adapted from David E. Kaufmann's Swifter routines symba_merge_tp.f90 and symba_merge_pl.f90 - !! - !! Adapted from Hal Levison's Swift routine symba5_merge.f - implicit none - ! Arguments - real(DP), intent(in) :: xr, yr, zr !! Relative position vector components - real(DP), intent(in) :: vxr, vyr, vzr !! Relative velocity vector components - real(DP), intent(in) :: Gmtot !! Sum of G*mass of colliding bodies - real(DP), intent(in) :: rlim !! Collision limit - Typically the sum of the radii of colliding bodies - real(DP), intent(in) :: dt !! Step size - logical, intent(in) :: lvdotr !! Logical flag indicating that these two bodies are approaching in the current substep - logical, intent(out) :: lcollision !! Logical flag indicating whether these two bodies will collide or not - logical, intent(out) :: lclosest !! Logical flag indicating that, while not a collision, this is the closest approach for this pair of bodies - ! Internals - real(DP) :: r2, rlim2, a, e, q, vdotr, tcr2, dt2 - - r2 = xr**2 + yr**2 + zr**2 - rlim2 = rlim**2 - lclosest = .false. - if (r2 <= rlim2) then ! checks if bodies are actively colliding in this time step - lcollision = .true. - else ! if they are not actively colliding in this time step, checks if they are going to collide next time step based on velocities and q - lcollision = .false. - vdotr = xr * vxr + yr * vyr + zr * vzr - if (lvdotr .and. (vdotr > 0.0_DP)) then - tcr2 = r2 / (vxr**2 + vyr**2 + vzr**2) - dt2 = dt**2 - if (tcr2 <= dt2) then - call orbel_xv2aeq(Gmtot, xr, yr, zr, vxr, vyr, vzr, a, e, q) - lcollision = (q < rlim) - end if - lclosest = .not. lcollision - end if - end if - - return - end subroutine symba_collision_check_one - - - function symba_collision_consolidate_impactors(pl, cb, param, idx_parent, impactors) result(lflag) - !! author: David A. Minton - !! - !! Loops through the pl-pl collision list and groups families together by index. Outputs the indices of all impactors%idx members, - !! and pairs of quantities (x and v vectors, mass, radius, Lspin, and Ip) that can be used to resolve the collisional outcome. - implicit none - ! Arguments - class(symba_pl), intent(inout) :: pl !! SyMBA massive body object - class(symba_cb), intent(inout) :: cb !! SyMBA central body object - class(symba_parameters), intent(in) :: param !! Current run configuration parameters with SyMBA additions - integer(I4B), dimension(2), intent(inout) :: idx_parent !! Index of the two bodies considered the "parents" of the collision - class(collision_impactors), intent(out) :: impactors - ! Result - logical :: lflag !! Logical flag indicating whether a impactors%idx was successfully created or not - ! Internals - type collidx_array - integer(I4B), dimension(:), allocatable :: id - integer(I4B), dimension(:), allocatable :: idx - end type collidx_array - type(collidx_array), dimension(2) :: parent_child_index_array - integer(I4B), dimension(2) :: nchild - integer(I4B) :: i, j, nimpactors, idx_child - real(DP), dimension(2) :: volume, density - real(DP) :: mchild, volchild - real(DP), dimension(NDIM) :: xc, vc, xcom, vcom, xchild, vchild, xcrossv - real(DP), dimension(NDIM,2) :: mxc, vcc - - nchild(:) = pl%kin(idx_parent(:))%nchild - ! If all of these bodies share a parent, but this is still a unique collision, move the last child - ! out of the parent's position and make it the secondary body - if (idx_parent(1) == idx_parent(2)) then - if (nchild(1) == 0) then ! There is only one valid body recorded in this pair (this could happen due to restructuring of the kinship relationships, though it should be rare) - lflag = .false. - call pl%reset_kinship([idx_parent(1)]) - return - end if - idx_parent(2) = pl%kin(idx_parent(1))%child(nchild(1)) - nchild(1) = nchild(1) - 1 - nchild(2) = 0 - pl%kin(idx_parent(:))%nchild = nchild(:) - pl%kin(idx_parent(2))%parent = idx_parent(1) - end if - - impactors%mass(:) = pl%mass(idx_parent(:)) ! Note: This is meant to mass, not G*mass, as the collisional regime determination uses mass values that will be converted to Si - impactors%radius(:) = pl%radius(idx_parent(:)) - volume(:) = (4.0_DP / 3.0_DP) * PI * impactors%radius(:)**3 - - ! Group together the ids and indexes of each collisional parent and its children - do j = 1, 2 - allocate(parent_child_index_array(j)%idx(nchild(j)+ 1)) - allocate(parent_child_index_array(j)%id(nchild(j)+ 1)) - associate(idx_arr => parent_child_index_array(j)%idx, & - id_arr => parent_child_index_array(j)%id, & - ncj => nchild(j), & - plkinj => pl%kin(idx_parent(j))) - idx_arr(1) = idx_parent(j) - if (ncj > 0) idx_arr(2:ncj + 1) = plkinj%child(1:ncj) - id_arr(:) = pl%id(idx_arr(:)) - end associate - end do - - ! Consolidate the groups of collsional parents with any children they may have into a single "impactors%idx" index array - nimpactors = 2 + sum(nchild(:)) - allocate(impactors%idx(nimpactors)) - impactors%idx = [parent_child_index_array(1)%idx(:),parent_child_index_array(2)%idx(:)] - - impactors%ncoll = count(pl%lcollision(impactors%idx(:))) - impactors%idx = pack(impactors%idx(:), pl%lcollision(impactors%idx(:))) - impactors%Lspin(:,:) = 0.0_DP - impactors%Ip(:,:) = 0.0_DP - - ! Find the barycenter of each body along with its children, if it has any - do j = 1, 2 - impactors%rb(:, j) = pl%rh(:, idx_parent(j)) + cb%rb(:) - impactors%vb(:, j) = pl%vb(:, idx_parent(j)) - ! Assume principal axis rotation about axis corresponding to highest moment of inertia (3rd Ip) - if (param%lrotation) then - impactors%Ip(:, j) = impactors%mass(j) * pl%Ip(:, idx_parent(j)) - impactors%Lspin(:, j) = impactors%Ip(3, j) * impactors%radius(j)**2 * pl%rot(:, idx_parent(j)) - end if - - if (nchild(j) > 0) then - do i = 1, nchild(j) ! Loop over all children and take the mass weighted mean of the properties - idx_child = parent_child_index_array(j)%idx(i + 1) - if (.not. pl%lcollision(idx_child)) cycle - mchild = pl%mass(idx_child) - xchild(:) = pl%rh(:, idx_child) + cb%rb(:) - vchild(:) = pl%vb(:, idx_child) - volchild = (4.0_DP / 3.0_DP) * PI * pl%radius(idx_child)**3 - volume(j) = volume(j) + volchild - ! Get angular momentum of the child-parent pair and add that to the spin - ! Add the child's spin - if (param%lrotation) then - xcom(:) = (impactors%mass(j) * impactors%rb(:,j) + mchild * xchild(:)) / (impactors%mass(j) + mchild) - vcom(:) = (impactors%mass(j) * impactors%vb(:,j) + mchild * vchild(:)) / (impactors%mass(j) + mchild) - xc(:) = impactors%rb(:, j) - xcom(:) - vc(:) = impactors%vb(:, j) - vcom(:) - xcrossv(:) = xc(:) .cross. vc(:) - impactors%Lspin(:, j) = impactors%Lspin(:, j) + impactors%mass(j) * xcrossv(:) - - xc(:) = xchild(:) - xcom(:) - vc(:) = vchild(:) - vcom(:) - xcrossv(:) = xc(:) .cross. vc(:) - impactors%Lspin(:, j) = impactors%Lspin(:, j) + mchild * xcrossv(:) - - impactors%Lspin(:, j) = impactors%Lspin(:, j) + mchild * pl%Ip(3, idx_child) & - * pl%radius(idx_child)**2 & - * pl%rot(:, idx_child) - impactors%Ip(:, j) = impactors%Ip(:, j) + mchild * pl%Ip(:, idx_child) - end if - - ! Merge the child and parent - impactors%mass(j) = impactors%mass(j) + mchild - impactors%rb(:, j) = xcom(:) - impactors%vb(:, j) = vcom(:) - end do - end if - density(j) = impactors%mass(j) / volume(j) - impactors%radius(j) = (3 * volume(j) / (4 * PI))**(1.0_DP / 3.0_DP) - if (param%lrotation) impactors%Ip(:, j) = impactors%Ip(:, j) / impactors%mass(j) - end do - lflag = .true. - - xcom(:) = (impactors%mass(1) * impactors%rb(:, 1) + impactors%mass(2) * impactors%rb(:, 2)) / sum(impactors%mass(:)) - vcom(:) = (impactors%mass(1) * impactors%vb(:, 1) + impactors%mass(2) * impactors%vb(:, 2)) / sum(impactors%mass(:)) - mxc(:, 1) = impactors%mass(1) * (impactors%rb(:, 1) - xcom(:)) - mxc(:, 2) = impactors%mass(2) * (impactors%rb(:, 2) - xcom(:)) - vcc(:, 1) = impactors%vb(:, 1) - vcom(:) - vcc(:, 2) = impactors%vb(:, 2) - vcom(:) - impactors%Lorbit(:,:) = mxc(:,:) .cross. vcc(:,:) - - ! Destroy the kinship relationships for all members of this impactors%idx - call pl%reset_kinship(impactors%idx(:)) - - return - end function symba_collision_consolidate_impactors - - - module subroutine symba_collision_extract_collisions_from_encounters(self, system, param) - !! author: David A. Minton - !! - !! Processes the pl-pl encounter list remove only those encounters that led to a collision - !! - implicit none - ! Arguments - class(symba_plplenc), intent(inout) :: self !! SyMBA pl-pl encounter list - class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - ! Internals - logical, dimension(:), allocatable :: lplpl_collision - 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, nplplenc - - select type (pl => system%pl) - class is (symba_pl) - 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 - ! Collisions have been detected in this step. So we need to determine which of them are between unique bodies. - - ! Get the subset of pl-pl encounters that lead to a collision - ncollisions = count(lplpl_collision(:)) - allocate(collision_idx(ncollisions)) - collision_idx = pack([(i, i=1, nplplenc)], lplpl_collision) - - ! Get the subset of collisions that involve a unique pair of parents - allocate(lplpl_unique_parent(ncollisions)) - - lplpl_unique_parent(:) = plparent(idx1(collision_idx(:))) /= plparent(idx2(collision_idx(:))) - nunique_parent = count(lplpl_unique_parent(:)) - allocate(unique_parent_idx(nunique_parent)) - unique_parent_idx = pack(collision_idx(:), lplpl_unique_parent(:)) - - ! Scrub all pl-pl collisions involving unique pairs of parents, which will remove all duplicates and leave behind - ! all pairs that have themselves as parents but are not part of the unique parent list. This can hapepn in rare cases - ! due to restructuring of parent/child relationships when there are large numbers of multi-body collisions in a single - ! step - lplpl_unique_parent(:) = .true. - do index_coll = 1, ncollisions - associate(ip1 => plparent(idx1(collision_idx(index_coll))), ip2 => plparent(idx2(collision_idx(index_coll)))) - lplpl_unique_parent(:) = .not. ( any(plparent(idx1(unique_parent_idx(:))) == ip1) .or. & - any(plparent(idx2(unique_parent_idx(:))) == ip1) .or. & - any(plparent(idx1(unique_parent_idx(:))) == ip2) .or. & - any(plparent(idx2(unique_parent_idx(:))) == ip2) ) - end associate - end do - - ! Reassemble collision index list to include only those containing the unique pairs of parents, plus all the non-unique pairs that don't - ! contain a parent body on the unique parent list. - ncollisions = nunique_parent + count(lplpl_unique_parent) - collision_idx = [unique_parent_idx(:), pack(collision_idx(:), lplpl_unique_parent(:))] - - ! Create a mask that contains only the pl-pl encounters that did not result in a collision, and then discard them - lplpl_collision(:) = .false. - lplpl_collision(collision_idx(:)) = .true. - call plplenc_list%spill(system%plplcollision_list, lplpl_collision, ldestructive=.true.) ! Extract any encounters that are not collisions from the list. - end associate - end select - - return - end subroutine symba_collision_extract_collisions_from_encounters - - - module subroutine symba_collision_make_impactors_pl(self, idx) - !! author: Jennifer L.L. Pouplin, Carlisle A. wishard, and David A. Minton - !! - !! When a single body is involved in more than one collision in a single step, it becomes part of a impactors%idx. - !! The largest body involved in a multi-body collision is the "parent" and all bodies that collide with it are its "children," - !! including those that collide with the children. - !! - !! Adapted from David E. Kaufmann's Swifter routine symba_merge_pl.f90 - !! - !! Adapted from Hal Levison's Swift routine symba5_merge.f - implicit none - ! Arguments - class(symba_pl), intent(inout) :: self !! SyMBA massive body object - integer(I4B), dimension(2), intent(in) :: idx !! Array holding the indices of the two bodies involved in the collision - ! Internals - integer(I4B) :: i, j, index_parent, index_child, p1, p2 - integer(I4B) :: nchild_inherit, nchild_orig, nchild_new - integer(I4B), dimension(:), allocatable :: temp - - associate(pl => self) - p1 = pl%kin(idx(1))%parent - p2 = pl%kin(idx(2))%parent - if (p1 == p2) return ! This is a collision between to children of a shared parent. We will ignore it. - - if (pl%mass(p1) > pl%mass(p2)) then - index_parent = p1 - index_child = p2 - else - index_parent = p2 - index_child = p1 - end if - - ! Expand the child array (or create it if necessary) and copy over the previous lists of children - nchild_orig = pl%kin(index_parent)%nchild - nchild_inherit = pl%kin(index_child)%nchild - nchild_new = nchild_orig + nchild_inherit + 1 - allocate(temp(nchild_new)) - - if (nchild_orig > 0) temp(1:nchild_orig) = pl%kin(index_parent)%child(1:nchild_orig) - ! Find out if the child body has any children of its own. The new parent wil inherit these children - if (nchild_inherit > 0) then - temp(nchild_orig+1:nchild_orig+nchild_inherit) = pl%kin(index_child)%child(1:nchild_inherit) - do i = 1, nchild_inherit - j = pl%kin(index_child)%child(i) - ! Set the childrens' parent to the new parent - pl%kin(j)%parent = index_parent - end do - end if - call pl%reset_kinship([index_child]) - ! Add the new child to its parent - pl%kin(index_child)%parent = index_parent - temp(nchild_new) = index_child - ! Save the new child array to the parent - pl%kin(index_parent)%nchild = nchild_new - call move_alloc(from=temp, to=pl%kin(index_parent)%child) - end associate - - return - end subroutine symba_collision_make_impactors_pl - - - subroutine symba_collision_mergeaddsub(system, param, t, status) - !! author: David A. Minton - !! - !! Fills the pl_discards and pl_adds with removed and added bodies - !! - implicit none - ! Arguments - class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object - class(symba_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions - real(DP), intent(in) :: t !! Time of collision - integer(I4B), intent(in) :: status !! Status flag to assign to adds - ! Internals - integer(I4B) :: i, ibiggest, ismallest, iother, nstart, nend, nimpactors, nfrag - logical, dimension(system%pl%nbody) :: lmask - class(symba_pl), allocatable :: plnew, plsub - character(*), parameter :: FRAGFMT = '("Newbody",I0.7)' - character(len=NAMELEN) :: newname, origin_type - - select type(pl => system%pl) - class is (symba_pl) - select type(pl_discards => system%pl_discards) - class is (symba_merger) - associate(info => pl%info, pl_adds => system%pl_adds, cb => system%cb, npl => pl%nbody, & - collision_system => system%collision_system, impactors => system%collision_system%impactors, fragments => system%collision_system%fragments) - ! Add the impactors%idx bodies to the subtraction list - nimpactors = impactors%ncoll - nfrag = fragments%nbody - - param%maxid_collision = max(param%maxid_collision, maxval(system%pl%info(:)%collision_id)) - param%maxid_collision = param%maxid_collision + 1 - - ! Setup new bodies - allocate(plnew, mold=pl) - call plnew%setup(nfrag, param) - ibiggest = impactors%idx(maxloc(pl%Gmass(impactors%idx(:)), dim=1)) - ismallest = impactors%idx(minloc(pl%Gmass(impactors%idx(:)), dim=1)) - - ! Copy over identification, information, and physical properties of the new bodies from the fragment list - plnew%id(1:nfrag) = fragments%id(1:nfrag) - plnew%rb(:, 1:nfrag) = fragments%rb(:, 1:nfrag) - plnew%vb(:, 1:nfrag) = fragments%vb(:, 1:nfrag) - call pl%vb2vh(cb) - call pl%rh2rb(cb) - do i = 1, nfrag - plnew%rh(:,i) = fragments%rb(:, i) - cb%rb(:) - plnew%vh(:,i) = fragments%vb(:, i) - cb%vb(:) - end do - plnew%mass(1:nfrag) = fragments%mass(1:nfrag) - plnew%Gmass(1:nfrag) = param%GU * fragments%mass(1:nfrag) - plnew%radius(1:nfrag) = fragments%radius(1:nfrag) - plnew%density(1:nfrag) = fragments%mass(1:nfrag) / fragments%radius(1:nfrag) - call plnew%set_rhill(cb) - - select case(status) - case(SUPERCATASTROPHIC) - plnew%status(1:nfrag) = NEW_PARTICLE - do i = 1, nfrag - write(newname, FRAGFMT) fragments%id(i) - call plnew%info(i)%set_value(origin_type="Supercatastrophic", origin_time=t, name=newname, & - origin_rh=plnew%rh(:,i), origin_vh=plnew%vh(:,i), & - collision_id=param%maxid_collision) - end do - do i = 1, nimpactors - if (impactors%idx(i) == ibiggest) then - iother = ismallest - else - iother = ibiggest - end if - call pl%info(impactors%idx(i))%set_value(status="Supercatastrophic", discard_time=t, & - discard_rh=pl%rh(:,i), discard_vh=pl%vh(:,i), & - discard_body_id=iother) - end do - case(DISRUPTION,HIT_AND_RUN_DISRUPT) - if (status == DISRUPTION) then - write(origin_type,*) "Disruption" - else if (status == HIT_AND_RUN_DISRUPT) then - write(origin_type,*) "Hit and run fragmention" - end if - call plnew%info(1)%copy(pl%info(ibiggest)) - plnew%status(1) = OLD_PARTICLE - do i = 2, nfrag - write(newname, FRAGFMT) fragments%id(i) - call plnew%info(i)%set_value(origin_type=origin_type, origin_time=t, name=newname, & - origin_rh=plnew%rh(:,i), origin_vh=plnew%vh(:,i), & - collision_id=param%maxid_collision) - end do - do i = 1, nimpactors - if (impactors%idx(i) == ibiggest) cycle - iother = ibiggest - call pl%info(impactors%idx(i))%set_value(status=origin_type, discard_time=t, & - discard_rh=pl%rh(:,i), discard_vh=pl%vh(:,i), & - discard_body_id=iother) - end do - case(MERGED) - call plnew%info(1)%copy(pl%info(ibiggest)) - plnew%status(1) = OLD_PARTICLE - do i = 1, nimpactors - if (impactors%idx(i) == ibiggest) cycle - - iother = ibiggest - call pl%info(impactors%idx(i))%set_value(status="MERGED", discard_time=t, discard_rh=pl%rh(:,i), & - discard_vh=pl%vh(:,i), discard_body_id=iother) - end do - end select - - if (param%lrotation) then - plnew%Ip(:, 1:nfrag) = fragments%Ip(:, 1:nfrag) - plnew%rot(:, 1:nfrag) = fragments%rot(:, 1:nfrag) - end if - - ! if (param%ltides) then - ! plnew%Q = pl%Q(ibiggest) - ! plnew%k2 = pl%k2(ibiggest) - ! plnew%tlag = pl%tlag(ibiggest) - ! end if - - !Copy over or set integration parameters for new bodies - plnew%lcollision(1:nfrag) = .false. - plnew%ldiscard(1:nfrag) = .false. - plnew%levelg(1:nfrag) = pl%levelg(ibiggest) - plnew%levelm(1:nfrag) = pl%levelm(ibiggest) - - plnew%lmtiny(1:nfrag) = plnew%Gmass(1:nfrag) < param%GMTINY - where(plnew%lmtiny(1:nfrag)) - plnew%info(1:nfrag)%particle_type = PL_TINY_TYPE_NAME - elsewhere - plnew%info(1:nfrag)%particle_type = PL_TYPE_NAME - end where - - ! Log the properties of the new bodies - allocate(collision_system%after%pl, source=plnew) - - ! Append the new merged body to the list - nstart = pl_adds%nbody + 1 - nend = pl_adds%nbody + nfrag - call pl_adds%append(plnew, lsource_mask=[(.true., i=1, nfrag)]) - ! Record how many bodies were added in this event - pl_adds%ncomp(nstart:nend) = plnew%nbody - - ! Add the discarded bodies to the discard list - pl%status(impactors%idx(:)) = MERGED - pl%ldiscard(impactors%idx(:)) = .true. - pl%lcollision(impactors%idx(:)) = .true. - lmask(:) = .false. - lmask(impactors%idx(:)) = .true. - - call plnew%setup(0, param) - deallocate(plnew) - - allocate(plsub, mold=pl) - call pl%spill(plsub, lmask, ldestructive=.false.) - - nstart = pl_discards%nbody + 1 - nend = pl_discards%nbody + nimpactors - call pl_discards%append(plsub, lsource_mask=[(.true., i = 1, nimpactors)]) - - ! Record how many bodies were subtracted in this event - pl_discards%ncomp(nstart:nend) = nimpactors - - call plsub%setup(0, param) - deallocate(plsub) - end associate - end select - end select - - return - end subroutine symba_collision_mergeaddsub - - - subroutine symba_resolve_collision(plplcollision_list , system, param, t) - !! author: David A. Minton - !! - !! Process list of collisions, determine the collisional regime, and then create fragments. - !! - implicit none - ! Arguments - class(symba_plplenc), intent(inout) :: plplcollision_list !! SyMBA pl-pl encounter list - class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object - class(symba_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions - real(DP), intent(in) :: t !! Time of collision - ! Internals - ! Internals - integer(I4B), dimension(2) :: idx_parent !! Index of the two bodies considered the "parents" of the collision - logical :: lgoodcollision - integer(I4B) :: i - - associate(ncollisions => plplcollision_list%nenc, idx1 => plplcollision_list%index1, idx2 => plplcollision_list%index2, collision_history => param%collision_history, & - collision_system => system%collision_system, impactors => system%collision_system%impactors, fragments => system%collision_system%fragments) - select type(pl => system%pl) - class is (symba_pl) - select type (cb => system%cb) - class is (symba_cb) - do i = 1, ncollisions - idx_parent(1) = pl%kin(idx1(i))%parent - idx_parent(2) = pl%kin(idx2(i))%parent - lgoodcollision = symba_collision_consolidate_impactors(pl, cb, param, idx_parent, impactors) - if ((.not. lgoodcollision) .or. any(pl%status(idx_parent(:)) /= COLLISION)) cycle - - if (param%lfragmentation) then - call impactors%get_regime(system, param) - else - impactors%regime = COLLRESOLVE_REGIME_MERGE - fragments%mtot = sum(impactors%mass(:)) - impactors%mass_dist(1) = fragments%mtot - impactors%mass_dist(2) = 0.0_DP - impactors%mass_dist(3) = 0.0_DP - impactors%rbcom(:) = (impactors%mass(1) * impactors%rb(:,1) + impactors%mass(2) * impactors%rb(:,2)) / fragments%mtot - impactors%vbcom(:) = (impactors%mass(1) * impactors%vb(:,1) + impactors%mass(2) * impactors%vb(:,2)) / fragments%mtot - end if - - call collision_history%take_snapshot(param,system, t, "before") - select case (impactors%regime) - case (COLLRESOLVE_REGIME_DISRUPTION, COLLRESOLVE_REGIME_SUPERCATASTROPHIC) - plplcollision_list%status(i) = symba_collision_casedisruption(system, param, t) - case (COLLRESOLVE_REGIME_HIT_AND_RUN) - plplcollision_list%status(i) = symba_collision_casehitandrun(system, param, t) - case (COLLRESOLVE_REGIME_MERGE, COLLRESOLVE_REGIME_GRAZE_AND_MERGE) - plplcollision_list%status(i) = symba_collision_casemerge(system, param, t) - case default - write(*,*) "Error in symba_collision, unrecognized collision regime" - call util_exit(FAILURE) - end select - call collision_history%take_snapshot(param,system, t, "after") - call impactors%reset() - end do - end select - end select - end associate - - return - end subroutine symba_resolve_collision - - - module subroutine symba_resolve_collision_plplenc(self, system, param, t, dt, irec) - !! author: David A. Minton - !! - !! Process the pl-pl collision list, then modifiy the massive bodies based on the outcome of the collision - !! - implicit none - ! Arguments - class(symba_plplenc), intent(inout) :: self !! SyMBA pl-pl encounter list - class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions - real(DP), intent(in) :: t !! Current simulation time - real(DP), intent(in) :: dt !! Current simulation step size - integer(I4B), intent(in) :: irec !! Current recursion level - ! Internals - real(DP) :: Eorbit_before, Eorbit_after - logical :: lplpl_collision - character(len=STRMAX) :: timestr - class(symba_parameters), allocatable :: tmp_param - - associate(plplenc_list => self, plplcollision_list => system%plplcollision_list) - select type(pl => system%pl) - class is (symba_pl) - select type(param) - class is (symba_parameters) - if (plplcollision_list%nenc == 0) return ! No collisions to resolve - ! Make sure that the heliocentric and barycentric coordinates are consistent with each other - call pl%vb2vh(system%cb) - call pl%rh2rb(system%cb) - - ! Get the energy before the collision is resolved - if (param%lenergy) then - call system%get_energy_and_momentum(param) - Eorbit_before = system%te - end if - - do - write(timestr,*) t - call io_log_one_message(FRAGGLE_LOG_OUT, "") - call io_log_one_message(FRAGGLE_LOG_OUT, "***********************************************************" // & - "***********************************************************") - call io_log_one_message(FRAGGLE_LOG_OUT, "Collision between massive bodies detected at time t = " // & - trim(adjustl(timestr))) - call io_log_one_message(FRAGGLE_LOG_OUT, "***********************************************************" // & - "***********************************************************") - allocate(tmp_param, source=param) - - call symba_resolve_collision(plplcollision_list, system, param, t) - - ! Destroy the collision list now that the collisions are resolved - call plplcollision_list%setup(0_I8B) - - if ((system%pl_adds%nbody == 0) .and. (system%pl_discards%nbody == 0)) exit - - ! Save the add/discard information to file - call system%write_discard(tmp_param) - - ! Rearrange the arrays: Remove discarded bodies, add any new bodies, resort, and recompute all indices and encounter lists - call pl%rearray(system, tmp_param) - - ! Destroy the add/discard list so that we don't append the same body multiple times if another collision is detected - call system%pl_discards%setup(0, param) - call system%pl_adds%setup(0, param) - deallocate(tmp_param) - - ! Check whether or not any of the particles that were just added are themselves in a collision state. This will generate a new plplcollision_list - call plplenc_list%collision_check(system, param, t, dt, irec, lplpl_collision) - - if (.not.lplpl_collision) exit - end do - - if (param%lenergy) then - call system%get_energy_and_momentum(param) - Eorbit_after = system%te - system%Ecollisions = system%Ecollisions + (Eorbit_after - Eorbit_before) - end if - - end select - end select - end associate - - return - end subroutine symba_resolve_collision_plplenc - - - module subroutine symba_resolve_collision_pltpenc(self, system, param, t, dt, irec) - !! author: David A. Minton - !! - !! Process the pl-tp collision list, then modifiy the massive bodies based on the outcome of the collision - !! - implicit none - ! Arguments - class(symba_pltpenc), intent(inout) :: self !! SyMBA pl-pl encounter list - class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters with SyMBA additions - real(DP), intent(in) :: t !! Current simulation tim - real(DP), intent(in) :: dt !! Current simulation step size - integer(I4B), intent(in) :: irec !! Current recursion level - - ! Make sure coordinate systems are all synced up due to being inside the recursion at this point - call system%pl%vb2vh(system%cb) - call system%tp%vb2vh(system%cb%vb) - call system%pl%b2h(system%cb) - call system%tp%b2h(system%cb) - - ! Discard the collider - call system%tp%discard(system, param) - - return - end subroutine symba_resolve_collision_pltpenc - -end submodule s_symba_collision \ No newline at end of file diff --git a/src/symba/symba_discard.f90 b/src/symba/symba_discard.f90 index 82741d695..a14911daa 100644 --- a/src/symba/symba_discard.f90 +++ b/src/symba/symba_discard.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule (symba_classes) s_symba_discard +submodule (symba) s_symba_discard use swiftest contains @@ -47,13 +47,13 @@ subroutine symba_discard_cb_pl(pl, system, param) write(timestr, *) system%t write(message, *) trim(adjustl(pl%info(i)%name)) // " (" // trim(adjustl(idstr)) // ")" // & " too far from the central body at t = " // trim(adjustl(timestr)) - call io_log_one_message(FRAGGLE_LOG_OUT, "") - call io_log_one_message(FRAGGLE_LOG_OUT, "***********************************************************" // & + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "") + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "***********************************************************" // & "***********************************************************") - call io_log_one_message(FRAGGLE_LOG_OUT, message) - call io_log_one_message(FRAGGLE_LOG_OUT, "***********************************************************" // & + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, message) + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "***********************************************************" // & "***********************************************************") - call io_log_one_message(FRAGGLE_LOG_OUT, "") + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "") call pl%info(i)%set_value(status="DISCARDED_RMAX", discard_time=system%t, discard_rh=pl%rh(:,i), & discard_vh=pl%vh(:,i)) else if ((param%rmin >= 0.0_DP) .and. (rh2 < rmin2)) then @@ -64,13 +64,13 @@ subroutine symba_discard_cb_pl(pl, system, param) write(timestr, *) system%t write(message, *) trim(adjustl(pl%info(i)%name)) // " (" // trim(adjustl(idstr)) // ")" // & " too close to the central body at t = " // trim(adjustl(timestr)) - call io_log_one_message(FRAGGLE_LOG_OUT, "") - call io_log_one_message(FRAGGLE_LOG_OUT, "************************************************************" // & + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "") + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "************************************************************" // & "************************************************************") - call io_log_one_message(FRAGGLE_LOG_OUT, message) - call io_log_one_message(FRAGGLE_LOG_OUT, "************************************************************" // & + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, message) + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "************************************************************" // & "************************************************************") - call io_log_one_message(FRAGGLE_LOG_OUT, "") + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "") call pl%info(i)%set_value(status="DISCARDED_RMIN", discard_time=system%t, discard_rh=pl%rh(:,i), & discard_vh=pl%vh(:,i), discard_body_id=cb%id) else if (param%rmaxu >= 0.0_DP) then @@ -85,13 +85,13 @@ subroutine symba_discard_cb_pl(pl, system, param) write(timestr, *) system%t write(message, *) trim(adjustl(pl%info(i)%name)) // " (" // trim(adjustl(idstr)) // ")" // & " is unbound and too far from barycenter at t = " // trim(adjustl(timestr)) - call io_log_one_message(FRAGGLE_LOG_OUT, "") - call io_log_one_message(FRAGGLE_LOG_OUT, "************************************************************" // & + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "") + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "************************************************************" // & "************************************************************") - call io_log_one_message(FRAGGLE_LOG_OUT, message) - call io_log_one_message(FRAGGLE_LOG_OUT, "************************************************************" // & + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, message) + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "************************************************************" // & "************************************************************") - call io_log_one_message(FRAGGLE_LOG_OUT, "") + call swiftest_io_log_one_message(FRAGGLE_LOG_OUT, "") call pl%info(i)%set_value(status="DISCARDED_RMAXU", discard_time=system%t, discard_rh=pl%rh(:,i), & discard_vh=pl%vh(:,i)) end if @@ -112,7 +112,7 @@ subroutine symba_discard_conserve_mtm(pl, system, param, ipl, lescape_body) ! Arguments class(symba_pl), intent(inout) :: pl class(symba_nbody_system), intent(inout) :: system - class(symba_parameters), intent(inout) :: param + class(swiftest_parameters), intent(inout) :: param integer(I4B), intent(in) :: ipl logical, intent(in) :: lescape_body ! Internals @@ -243,8 +243,6 @@ subroutine symba_discard_nonplpl(pl, system, param) nend = pl_discards%nbody + nsub call pl_discards%append(plsub, lsource_mask=[(.true., i = 1, nsub)]) - ! Record how many bodies were subtracted in this event - pl_discards%ncomp(nstart:nend) = nsub end if end select end associate @@ -262,7 +260,7 @@ subroutine symba_discard_nonplpl_conservation(pl, system, param) ! Arguments class(symba_pl), intent(inout) :: pl !! SyMBA test particle object class(symba_nbody_system), intent(inout) :: system !! SyMBA nbody system object - class(symba_parameters), intent(inout) :: param !! Current run configuration parameters + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters ! Internals integer(I4B) :: i, ndiscard, dstat logical :: lescape @@ -357,11 +355,11 @@ module subroutine symba_discard_pl(self, system, param) select type(system) class is (symba_nbody_system) select type(param) - class is (symba_parameters) - associate(pl => self, plplenc_list => system%plplenc_list, plplcollision_list => system%plplcollision_list) + class is (swiftest_parameters) + associate(pl => self, plpl_encounter => system%plpl_encounter, plpl_collision => system%plpl_collision) call pl%vb2vh(system%cb) call pl%rh2rb(system%cb) - !call plplenc_list%write(pl, pl, param) TODO: write the encounter list writer for NetCDF + !call plpl_encounter%write(pl, pl, param) TODO: write the encounter list writer for NetCDF call symba_discard_nonplpl(self, system, param) diff --git a/src/symba/symba_drift.f90 b/src/symba/symba_drift.f90 index 767ea8b01..126196c6c 100644 --- a/src/symba/symba_drift.f90 +++ b/src/symba/symba_drift.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. - submodule (symba_classes) s_symba_drift + submodule (symba) s_symba_drift use swiftest contains diff --git a/src/symba/symba_encounter_check.f90 b/src/symba/symba_encounter_check.f90 index f53061b93..eb05f0664 100644 --- a/src/symba/symba_encounter_check.f90 +++ b/src/symba/symba_encounter_check.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule (symba_classes) s_symba_encounter_check +submodule (symba) s_symba_encounter_check use swiftest contains @@ -34,7 +34,7 @@ module function symba_encounter_check_pl(self, param, system, dt, irec) result(l lany_encounter = .false. if (self%nbody == 0) return - associate(pl => self, plplenc_list => system%plplenc_list, cb => system%cb) + associate(pl => self, plpl_encounter => system%plpl_encounter, cb => system%cb) npl = pl%nbody nplm = pl%nplm @@ -51,25 +51,25 @@ module function symba_encounter_check_pl(self, param, system, dt, irec) result(l lany_encounter = nenc > 0_I8B if (lany_encounter) then - call plplenc_list%resize(nenc) - call move_alloc(lvdotr, plplenc_list%lvdotr) - call move_alloc(index1, plplenc_list%index1) - call move_alloc(index2, plplenc_list%index2) + call plpl_encounter%resize(nenc) + call move_alloc(lvdotr, plpl_encounter%lvdotr) + call move_alloc(index1, plpl_encounter%index1) + call move_alloc(index2, plpl_encounter%index2) end if if (lany_encounter) then do k = 1_I8B, nenc - plplenc_list%t = system%t - i = plplenc_list%index1(k) - j = plplenc_list%index2(k) - plplenc_list%id1(k) = pl%id(i) - plplenc_list%id2(k) = pl%id(j) - plplenc_list%status(k) = ACTIVE - plplenc_list%level(k) = irec - plplenc_list%r1(:,k) = pl%rh(:,i) - plplenc_list%r2(:,k) = pl%rh(:,j) - plplenc_list%v1(:,k) = pl%vb(:,i) - cb%vb(:) - plplenc_list%v2(:,k) = pl%vb(:,j) - cb%vb(:) + plpl_encounter%t = system%t + i = plpl_encounter%index1(k) + j = plpl_encounter%index2(k) + plpl_encounter%id1(k) = pl%id(i) + plpl_encounter%id2(k) = pl%id(j) + plpl_encounter%status(k) = ACTIVE + plpl_encounter%level(k) = irec + plpl_encounter%r1(:,k) = pl%rh(:,i) + plpl_encounter%r2(:,k) = pl%rh(:,j) + plpl_encounter%v1(:,k) = pl%vb(:,i) - cb%vb(:) + plpl_encounter%v2(:,k) = pl%vb(:,j) - cb%vb(:) pl%lencounter(i) = .true. pl%lencounter(j) = .true. pl%levelg(i) = irec @@ -87,11 +87,11 @@ module function symba_encounter_check_pl(self, param, system, dt, irec) result(l end function symba_encounter_check_pl - module function symba_encounter_check(self, param, system, dt, irec) result(lany_encounter) + module function symba_encounter_io_netcdf_check(self, param, system, dt, irec) result(lany_encounter) !! author: David A. Minton !! !! Check for an encounter between test particles and massive bodies in the plplenc and pltpenc list. - !! Note: This method works for the polymorphic symba_pltpenc and symba_plplenc types. + !! Note: This method works for the polymorphic pltp_encounter and plpl_encounter types. !! !! Adapted from portions of David E. Kaufmann's Swifter routine: symba_step_recur.f90 implicit none @@ -114,9 +114,9 @@ module function symba_encounter_check(self, param, system, dt, irec) result(lany if (self%nenc == 0) return select type(self) - class is (symba_plplenc) + class is (plpl_encounter) isplpl = .true. - class is (symba_pltpenc) + class is (pltp_encounter) isplpl = .false. end select @@ -222,21 +222,21 @@ module function symba_encounter_check_tp(self, param, system, dt, irec) result(l lany_encounter = nenc > 0 if (lany_encounter) then - associate(pltpenc_list => system%pltpenc_list) - call pltpenc_list%resize(nenc) - pltpenc_list%status(1:nenc) = ACTIVE - pltpenc_list%level(1:nenc) = irec - call move_alloc(index1, pltpenc_list%index1) - call move_alloc(index2, pltpenc_list%index2) - call move_alloc(lvdotr, pltpenc_list%lvdotr) - pltpenc_list%id1(1:nenc) = pl%id(pltpenc_list%index1(1:nenc)) - pltpenc_list%id2(1:nenc) = tp%id(pltpenc_list%index2(1:nenc)) + associate(pltp_encounter => system%pltp_encounter) + call pltp_encounter%resize(nenc) + pltp_encounter%status(1:nenc) = ACTIVE + pltp_encounter%level(1:nenc) = irec + call move_alloc(index1, pltp_encounter%index1) + call move_alloc(index2, pltp_encounter%index2) + call move_alloc(lvdotr, pltp_encounter%lvdotr) + pltp_encounter%id1(1:nenc) = pl%id(pltp_encounter%index1(1:nenc)) + pltp_encounter%id2(1:nenc) = tp%id(pltp_encounter%index2(1:nenc)) select type(pl) class is (symba_pl) pl%lencounter(1:npl) = .false. do k = 1_I8B, nenc - plind = pltpenc_list%index1(k) - tpind = pltpenc_list%index2(k) + plind = pltp_encounter%index1(k) + tpind = pltp_encounter%index2(k) pl%lencounter(plind) = .true. pl%levelg(plind) = irec pl%levelm(plind) = irec diff --git a/src/symba/symba_gr.f90 b/src/symba/symba_gr.f90 index fea0f46d9..5457417e0 100644 --- a/src/symba/symba_gr.f90 +++ b/src/symba/symba_gr.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(symba_classes) s_symba_gr +submodule(symba) s_symba_gr use swiftest contains diff --git a/src/symba/symba_io.f90 b/src/symba/symba_io.f90 index 29f1c1fbe..e5fdbc25d 100644 --- a/src/symba/symba_io.f90 +++ b/src/symba/symba_io.f90 @@ -7,206 +7,10 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule (symba_classes) s_symba_io +submodule (symba) s_symba_io use swiftest contains - - module subroutine symba_io_param_reader(self, unit, iotype, v_list, iostat, iomsg) - !! author: The Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott - !! - !! Read in parameters specific to the SyMBA integrator, then calls the base io_param_reader. - !! - !! Adapted from David E. Kaufmann's Swifter routine io_init_param.f90 - !! Adapted from Martin Duncan's Swift routine io_init_param.f - implicit none - ! Arguments - class(symba_parameters), intent(inout) :: self !! Collection of parameters - integer, intent(in) :: unit !! File unit number - character(len=*), intent(in) :: iotype !! Dummy argument passed to the input/output procedure contains the text from the char-literal-constant, prefixed with DT. - !! If you do not include a char-literal-constant, the iotype argument contains only DT. - character(len=*), intent(in) :: v_list(:) !! The first element passes the integrator code to the reader - integer, intent(out) :: iostat !! IO status code - character(len=*), intent(inout) :: iomsg !! Message to pass if iostat /= 0 - ! internals - integer(I4B) :: ilength, ifirst, ilast !! Variables used to parse input file - character(STRMAX) :: line !! Line of the input file - character (len=:), allocatable :: line_trim,param_name, param_value !! Strings used to parse the param file - integer(I4B) :: nseeds, nseeds_from_file, i - logical :: seed_set = .false. !! Is the random seed set in the input file? - character(len=*),parameter :: linefmt = '(A)' - - associate(param => self) - open(unit = unit, file = param%param_file_name, status = 'old', err = 667, iomsg = iomsg) - call random_seed(size = nseeds) - if (allocated(param%seed)) deallocate(param%seed) - allocate(param%seed(nseeds)) - do - read(unit = unit, fmt = linefmt, iostat = iostat, end = 1, err = 667, iomsg = iomsg) line - line_trim = trim(adjustl(line)) - ilength = len(line_trim) - if ((ilength /= 0)) then - ifirst = 1 - ! Read the pair of tokens. The first one is the parameter name, the second is the value. - param_name = io_get_token(line_trim, ifirst, ilast, iostat) - if (param_name == '') cycle ! No parameter name (usually because this line is commented out) - call io_toupper(param_name) - ifirst = ilast + 1 - param_value = io_get_token(line_trim, ifirst, ilast, iostat) - select case (param_name) - case ("OUT_STAT") ! We need to duplicate this from the standard io_param_reader in order to make sure that the restart flag gets set properly in SyMBA - call io_toupper(param_value) - param%out_stat = param_value - case ("FRAGMENTATION") - call io_toupper(param_value) - if (param_value == "YES" .or. param_value == "T") self%lfragmentation = .true. - case ("GMTINY") - read(param_value, *) param%GMTINY - case ("MIN_GMFRAG") - read(param_value, *) param%min_GMfrag - case ("ENCOUNTER_SAVE") - call io_toupper(param_value) - read(param_value, *) param%encounter_save - case("SEED") - read(param_value, *) nseeds_from_file - ! Because the number of seeds can vary between compilers/systems, we need to make sure we can handle cases in which the input file has a different - ! number of seeds than the current system. If the number of seeds in the file is smaller than required, we will use them as a source to fill in the missing elements. - ! If the number of seeds in the file is larger than required, we will truncate the seed array. - if (nseeds_from_file > nseeds) then - nseeds = nseeds_from_file - deallocate(param%seed) - allocate(param%seed(nseeds)) - do i = 1, nseeds - ifirst = ilast + 2 - param_value = io_get_token(line, ifirst, ilast, iostat) - read(param_value, *) param%seed(i) - end do - else ! Seed array in file is too small - do i = 1, nseeds_from_file - ifirst = ilast + 2 - param_value = io_get_token(line, ifirst, ilast, iostat) - read(param_value, *) param%seed(i) - end do - param%seed(nseeds_from_file+1:nseeds) = [(param%seed(1) - param%seed(nseeds_from_file) + i, & - i=nseeds_from_file+1, nseeds)] - end if - seed_set = .true. - end select - end if - end do - 1 continue - close(unit) - - param%lrestart = (param%out_stat == "APPEND") - - if (self%GMTINY < 0.0_DP) then - write(iomsg,*) "GMTINY invalid or not set: ", self%GMTINY - iostat = -1 - return - end if - - if (param%lfragmentation) then - if (seed_set) then - call random_seed(put = param%seed) - else - call random_seed(get = param%seed) - end if - if (param%min_GMfrag < 0.0_DP) param%min_GMfrag = param%GMTINY - end if - - ! All reporting of collision information in SyMBA (including mergers) is now recorded in the Fraggle logfile - call io_log_start(param, FRAGGLE_LOG_OUT, "Fraggle logfile") - - if ((param%encounter_save /= "NONE") .and. & - (param%encounter_save /= "TRAJECTORY") .and. & - (param%encounter_save /= "CLOSEST") .and. & - (param%encounter_save /= "BOTH")) then - write(iomsg,*) 'Invalid encounter_save parameter: ',trim(adjustl(param%out_type)) - write(iomsg,*) 'Valid options are NONE, TRAJECTORY, CLOSEST, or BOTH' - iostat = -1 - return - end if - - param%lenc_save_trajectory = (param%encounter_save == "TRAJECTORY") .or. (param%encounter_save == "BOTH") - param%lenc_save_closest = (param%encounter_save == "CLOSEST") .or. (param%encounter_save == "BOTH") - - ! Call the base method (which also prints the contents to screen) - call io_param_reader(param, unit, iotype, v_list, iostat, iomsg) - end associate - - iostat = 0 - - return - 667 continue - write(*,*) "Error reading SyMBA parameters in param file: ", trim(adjustl(iomsg)) - end subroutine symba_io_param_reader - - - module subroutine symba_io_param_writer(self, unit, iotype, v_list, iostat, iomsg) - !! author: David A. Minton - !! - !! Dump integration parameters specific to SyMBA to file and then call the base io_param_writer method. - !! - !! Adapted from David E. Kaufmann's Swifter routine io_dump_param.f90 - !! Adapted from Martin Duncan's Swift routine io_dump_param.f - implicit none - ! Arguments - class(symba_parameters),intent(in) :: self !! Collection of SyMBA parameters - integer, intent(in) :: unit !! File unit number - character(len=*), intent(in) :: iotype !! Dummy argument passed to the input/output procedure contains the text from the char-literal-constant, prefixed with DT. - !! If you do not include a char-literal-constant, the iotype argument contains only DT. - integer, intent(in) :: v_list(:) !! Not used in this procedure - integer, intent(out) :: iostat !! IO status code - character(len=*), intent(inout) :: iomsg !! Message to pass if iostat /= 0 - ! Internals - integer(I4B) :: nseeds - - associate(param => self) - call io_param_writer(param, unit, iotype, v_list, iostat, iomsg) - - ! Special handling is required for writing the random number seed array as its size is not known until runtime - ! For the "SEED" parameter line, the first value will be the size of the seed array and the rest will be the seed array elements - call io_param_writer_one("GMTINY",param%GMTINY, unit) - call io_param_writer_one("MIN_GMFRAG",param%min_GMfrag, unit) - call io_param_writer_one("FRAGMENTATION",param%lfragmentation, unit) - if (param%lfragmentation) then - nseeds = size(param%seed) - call io_param_writer_one("SEED", [nseeds, param%seed(:)], unit) - end if - - iostat = 0 - end associate - - return - 667 continue - write(*,*) "Error writing parameter file for SyMBA: " // trim(adjustl(iomsg)) - end subroutine symba_io_param_writer - - - module subroutine symba_io_write_discard(self, param) - !! author: David A. Minton - !! - !! Write the metadata of the discarded body to the output file - implicit none - class(symba_nbody_system), intent(inout) :: self !! SyMBA nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - ! Internals - - associate(pl => self%pl, npl => self%pl%nbody, pl_adds => self%pl_adds) - - if (self%tp_discards%nbody > 0) call self%tp_discards%write_info(param%system_history%nc, param) - select type(pl_discards => self%pl_discards) - class is (symba_merger) - if (pl_discards%nbody == 0) return - - call pl_discards%write_info(param%system_history%nc, param) - end select - end associate - - return - - end subroutine symba_io_write_discard - end submodule s_symba_io diff --git a/src/symba/symba_kick.f90 b/src/symba/symba_kick.f90 index cdad09045..5fbe3d8f6 100644 --- a/src/symba/symba_kick.f90 +++ b/src/symba/symba_kick.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(symba_classes) s_symba_kick +submodule(symba) s_symba_kick use swiftest contains @@ -34,7 +34,7 @@ module subroutine symba_kick_getacch_int_pl(self, param) call itimer%time_this_loop(param, self%nplplm, self) lfirst = .false. else - if (itimer%check(param, self%nplplm)) call itimer%time_this_loop(param, self%nplplm, self) + if (itimer%io_netcdf_check(param, self%nplplm)) call itimer%time_this_loop(param, self%nplplm, self) end if else param%lflatten_interactions = .false. @@ -77,16 +77,16 @@ module subroutine symba_kick_getacch_pl(self, system, param, t, lbeg) if (self%nbody == 0) return select type(system) class is (symba_nbody_system) - associate(pl => self, npl => self%nbody, nplm => self%nplm, plplenc_list => system%plplenc_list, radius => self%radius) + associate(pl => self, npl => self%nbody, nplm => self%nplm, plpl_encounter => system%plpl_encounter, radius => self%radius) ! Apply kicks to all bodies (including those in the encounter list) call helio_kick_getacch_pl(pl, system, param, t, lbeg) - if (plplenc_list%nenc > 0) then + if (plpl_encounter%nenc > 0) then ! Remove kicks from bodies involved currently in the encounter list, as these are dealt with separately. ah_enc(:,:) = 0.0_DP - nplplenc = int(plplenc_list%nenc, kind=I8B) + nplplenc = int(plpl_encounter%nenc, kind=I8B) allocate(k_plpl_enc(2,nplplenc)) - k_plpl_enc(1,1:nplplenc) = plplenc_list%index1(1:nplplenc) - k_plpl_enc(2,1:nplplenc) = plplenc_list%index2(1:nplplenc) + k_plpl_enc(1,1:nplplenc) = plpl_encounter%index1(1:nplplenc) + k_plpl_enc(2,1:nplplenc) = plpl_encounter%index2(1:nplplenc) call kick_getacch_int_all_flat_pl(npl, nplplenc, k_plpl_enc, pl%rh, pl%Gmass, pl%radius, ah_enc) pl%ah(:,1:npl) = pl%ah(:,1:npl) - ah_enc(:,1:npl) end if @@ -121,17 +121,17 @@ module subroutine symba_kick_getacch_tp(self, system, param, t, lbeg) select type(system) class is (symba_nbody_system) associate(tp => self, cb => system%cb, pl => system%pl, & - pltpenc_list => system%pltpenc_list, npltpenc => system%pltpenc_list%nenc) + pltp_encounter => system%pltp_encounter, npltpenc => system%pltp_encounter%nenc) call helio_kick_getacch_tp(tp, system, param, t, lbeg) ! Remove accelerations from encountering pairs do k = 1, npltpenc - i = pltpenc_list%index1(k) - j = pltpenc_list%index2(k) + i = pltp_encounter%index1(k) + j = pltp_encounter%index2(k) if (tp%lmask(j)) then if (lbeg) then dx(:) = tp%rh(:,j) - pl%rbeg(:,i) else - dx(:) = tp%rh(:,j) - pl%xend(:,i) + dx(:) = tp%rh(:,j) - pl%rend(:,i) end if rjj = dot_product(dx(:), dx(:)) fac = pl%Gmass(i) / (rjj * sqrt(rjj)) @@ -148,7 +148,7 @@ module subroutine symba_kick_encounter(self, system, dt, irec, sgn) !! author: David A. Minton !! !! Kick barycentric velocities of massive bodies and ACTIVE test particles within SyMBA recursion. - !! Note: This method works for the polymorphic symba_pltpenc and symba_plplenc types + !! Note: This method works for the polymorphic pltp_encounter and plpl_encounter types !! !! Adapted from David E. Kaufmann's Swifter routine: symba_kick.f90 !! Adapted from Hal Levison's Swift routine symba5_kick.f @@ -171,9 +171,9 @@ module subroutine symba_kick_encounter(self, system, dt, irec, sgn) if (self%nenc == 0) return select type(self) - class is (symba_plplenc) + class is (plpl_encounter) isplpl = .true. - class is (symba_pltpenc) + class is (pltp_encounter) isplpl = .false. end select select type(pl => system%pl) diff --git a/src/symba/symba_setup.f90 b/src/symba/symba_setup.f90 index 9a4ace98f..efd60f636 100644 --- a/src/symba/symba_setup.f90 +++ b/src/symba/symba_setup.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(symba_classes) s_symba_setup +submodule(symba) s_symba_setup use swiftest contains @@ -25,42 +25,15 @@ module subroutine symba_setup_initialize_system(self, param) ! Call parent method associate(system => self) call helio_setup_initialize_system(system, param) - call system%pltpenc_list%setup(0_I8B) - call system%plplenc_list%setup(0_I8B) - call system%plplcollision_list%setup(0_I8B) + call system%pltp_encounter%setup(0_I8B) + call system%plpl_encounter%setup(0_I8B) + call system%plpl_collision%setup(0_I8B) end associate return end subroutine symba_setup_initialize_system - module subroutine symba_setup_merger(self, n, param) - !! author: David A. Minton - !! - !! Allocate SyMBA test particle structure - !! - !! Equivalent in functionality to David E. Kaufmann's Swifter routine symba_setup.f90 - implicit none - ! Arguments - class(symba_merger), intent(inout) :: self !! SyMBA merger list object - integer(I4B), intent(in) :: n !! Number of particles to allocate space for - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameter - - !> Call allocation method for parent class. In this case, helio_pl does not have its own setup method so we use the base method for swiftest_pl - call symba_setup_pl(self, n, param) - if (n < 0) return - - if (allocated(self%ncomp)) deallocate(self%ncomp) - - if (n == 0) return - - allocate(self%ncomp(n)) - self%ncomp(:) = 0 - - return - end subroutine symba_setup_merger - - module subroutine symba_setup_pl(self, n, param) !! author: David A. Minton !! @@ -79,11 +52,6 @@ module subroutine symba_setup_pl(self, n, param) call setup_pl(self, n, param) if (n == 0) return - allocate(self%lcollision(n)) - allocate(self%lencounter(n)) - allocate(self%lmtiny(n)) - allocate(self%nplenc(n)) - allocate(self%ntpenc(n)) allocate(self%levelg(n)) allocate(self%levelm(n)) allocate(self%isperi(n)) @@ -91,11 +59,7 @@ module subroutine symba_setup_pl(self, n, param) allocate(self%atp(n)) allocate(self%kin(n)) - self%lcollision(:) = .false. - self%lencounter(:) = .false. - self%lmtiny(:) = .false. - self%nplenc(:) = 0 - self%ntpenc(:) = 0 + self%levelg(:) = -1 self%levelm(:) = -1 self%isperi(:) = 0 @@ -147,11 +111,9 @@ module subroutine symba_setup_tp(self, n, param) call setup_tp(self, n, param) if (n == 0) return - allocate(self%nplenc(n)) allocate(self%levelg(n)) allocate(self%levelm(n)) - self%nplenc(:) = 0 self%levelg(:) = -1 self%levelm(:) = -1 diff --git a/src/symba/symba_step.f90 b/src/symba/symba_step.f90 index 68645d7b8..d51f66d89 100644 --- a/src/symba/symba_step.f90 +++ b/src/symba/symba_step.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule (symba_classes) s_symba_step +submodule (symba) s_symba_step use swiftest contains @@ -33,7 +33,7 @@ module subroutine symba_step_system(self, param, t, dt) select type(tp => self%tp) class is (symba_tp) select type(param) - class is (symba_parameters) + class is (swiftest_parameters) associate(encounter_history => param%encounter_history) call self%reset(param) lencounter = pl%encounter_check(param, self, dt, 0) .or. tp%encounter_check(param, self, dt, 0) @@ -132,7 +132,7 @@ module subroutine symba_step_set_recur_levels_system(self, ireci) ! Internals integer(I4B) :: irecp - associate(system => self, plplenc_list => self%plplenc_list, pltpenc_list => self%pltpenc_list, & + associate(system => self, plpl_encounter => self%plpl_encounter, pltp_encounter => self%pltp_encounter, & npl => self%pl%nbody, ntp => self%tp%nbody) select type(pl => self%pl) class is (symba_pl) @@ -142,14 +142,14 @@ module subroutine symba_step_set_recur_levels_system(self, ireci) if (npl >0) where(pl%levelg(1:npl) == irecp) pl%levelg(1:npl) = ireci if (ntp > 0) where(tp%levelg(1:ntp) == irecp) tp%levelg(1:ntp) = ireci - if (plplenc_list%nenc > 0) then - where(plplenc_list%level(1:plplenc_list%nenc) == irecp) - plplenc_list%level(1:plplenc_list%nenc) = ireci + if (plpl_encounter%nenc > 0) then + where(plpl_encounter%level(1:plpl_encounter%nenc) == irecp) + plpl_encounter%level(1:plpl_encounter%nenc) = ireci endwhere end if - if (pltpenc_list%nenc > 0) then - where(pltpenc_list%level(1:pltpenc_list%nenc) == irecp) - pltpenc_list%level(1:pltpenc_list%nenc) = ireci + if (pltp_encounter%nenc > 0) then + where(pltp_encounter%level(1:pltp_encounter%nenc) == irecp) + pltp_encounter%level(1:pltp_encounter%nenc) = ireci endwhere end if @@ -183,13 +183,13 @@ recursive module subroutine symba_step_recur_system(self, param, t, ireci) logical :: lencounter select type(param) - class is (symba_parameters) + class is (swiftest_parameters) select type(pl => self%pl) class is (symba_pl) select type(tp => self%tp) class is (symba_tp) - associate(system => self, plplenc_list => self%plplenc_list, pltpenc_list => self%pltpenc_list, & - lplpl_collision => self%plplenc_list%lcollision, lpltp_collision => self%pltpenc_list%lcollision, & + associate(system => self, plpl_encounter => self%plpl_encounter, pltp_encounter => self%pltp_encounter, & + lplpl_collision => self%plpl_encounter%lcollision, lpltp_collision => self%pltp_encounter%lcollision, & encounter_history => param%encounter_history) system%irec = ireci dtl = param%dt / (NTENC**ireci) @@ -207,14 +207,14 @@ recursive module subroutine symba_step_recur_system(self, param, t, ireci) nloops = NTENC end if do j = 1, nloops - lencounter = plplenc_list%encounter_check(param, system, dtl, irecp) & - .or. pltpenc_list%encounter_check(param, system, dtl, irecp) + lencounter = plpl_encounter%encounter_check(param, system, dtl, irecp) & + .or. pltp_encounter%encounter_check(param, system, dtl, irecp) - call plplenc_list%kick(system, dth, irecp, 1) - call pltpenc_list%kick(system, dth, irecp, 1) + call plpl_encounter%kick(system, dth, irecp, 1) + call pltp_encounter%kick(system, dth, irecp, 1) if (ireci /= 0) then - call plplenc_list%kick(system, dth, irecp, -1) - call pltpenc_list%kick(system, dth, irecp, -1) + call plpl_encounter%kick(system, dth, irecp, -1) + call pltp_encounter%kick(system, dth, irecp, -1) end if if (param%lgr) then @@ -233,19 +233,19 @@ recursive module subroutine symba_step_recur_system(self, param, t, ireci) call tp%gr_pos_kick(system, param, dth) end if - call plplenc_list%kick(system, dth, irecp, 1) - call pltpenc_list%kick(system, dth, irecp, 1) + call plpl_encounter%kick(system, dth, irecp, 1) + call pltp_encounter%kick(system, dth, irecp, 1) if (ireci /= 0) then - call plplenc_list%kick(system, dth, irecp, -1) - call pltpenc_list%kick(system, dth, irecp, -1) + call plpl_encounter%kick(system, dth, irecp, -1) + call pltp_encounter%kick(system, dth, irecp, -1) end if if (param%lclose) then - call plplenc_list%collision_check(system, param, t+j*dtl, dtl, ireci, lplpl_collision) - call pltpenc_list%collision_check(system, param, t+j*dtl, dtl, ireci, lpltp_collision) + call plpl_encounter%collision_io_netcdf_check(system, param, t+j*dtl, dtl, ireci, lplpl_collision) + call pltp_encounter%collision_io_netcdf_check(system, param, t+j*dtl, dtl, ireci, lpltp_collision) - if (lplpl_collision) call plplenc_list%resolve_collision(system, param, t+j*dtl, dtl, ireci) - if (lpltp_collision) call pltpenc_list%resolve_collision(system, param, t+j*dtl, dtl, ireci) + if (lplpl_collision) call plpl_encounter%resolve_collision(system, param, t+j*dtl, dtl, ireci) + if (lpltp_collision) call pltp_encounter%resolve_collision(system, param, t+j*dtl, dtl, ireci) end if if (param%lenc_save_trajectory) call encounter_history%take_snapshot(param, self, t+j*dtl, "trajectory") @@ -271,7 +271,7 @@ module subroutine symba_step_reset_system(self, param) implicit none ! Arguments class(symba_nbody_system), intent(inout) :: self !! SyMBA nbody system object - class(symba_parameters), intent(in) :: param !! Current run configuration parameters with SyMBA additions + class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters with SyMBA additions ! Internals integer(I4B) :: i integer(I8B) :: nenc_old @@ -282,9 +282,9 @@ module subroutine symba_step_reset_system(self, param) select type(tp => system%tp) class is (symba_tp) associate(npl => pl%nbody, ntp => tp%nbody) - nenc_old = system%plplenc_list%nenc - call system%plplenc_list%setup(0_I8B) - call system%plplcollision_list%setup(0_I8B) + nenc_old = system%plpl_encounter%nenc + call system%plpl_encounter%setup(0_I8B) + call system%plpl_collision%setup(0_I8B) if (npl > 0) then pl%lcollision(1:npl) = .false. call pl%reset_kinship([(i, i=1, npl)]) @@ -297,22 +297,22 @@ module subroutine symba_step_reset_system(self, param) pl%ldiscard(1:npl) = .false. pl%lmask(1:npl) = .true. call pl%set_renc(0) - call system%plplenc_list%setup(nenc_old) ! This resizes the pl-pl encounter list to be the same size as it was the last step, to decrease the number of potential resize operations that have to be one inside the step - system%plplenc_list%nenc = 0 ! Sets the true number of encounters back to 0 after resizing - system%plplenc_list%lcollision = .false. + call system%plpl_encounter%setup(nenc_old) ! This resizes the pl-pl encounter list to be the same size as it was the last step, to decrease the number of potential resize operations that have to be one inside the step + system%plpl_encounter%nenc = 0 ! Sets the true number of encounters back to 0 after resizing + system%plpl_encounter%lcollision = .false. end if - nenc_old = system%pltpenc_list%nenc - call system%pltpenc_list%setup(0_I8B) + nenc_old = system%pltp_encounter%nenc + call system%pltp_encounter%setup(0_I8B) if (ntp > 0) then tp%nplenc(1:ntp) = 0 tp%levelg(1:ntp) = -1 tp%levelm(1:ntp) = -1 tp%lmask(1:ntp) = .true. tp%ldiscard(1:ntp) = .false. - call system%pltpenc_list%setup(nenc_old)! This resizes the pl-tp encounter list to be the same size as it was the last step, to decrease the number of potential resize operations that have to be one inside the step - system%pltpenc_list%nenc = 0 ! Sets the true number of encounters back to 0 after resizing - system%pltpenc_list%lcollision = .false. + call system%pltp_encounter%setup(nenc_old)! This resizes the pl-tp encounter list to be the same size as it was the last step, to decrease the number of potential resize operations that have to be one inside the step + system%pltp_encounter%nenc = 0 ! Sets the true number of encounters back to 0 after resizing + system%pltp_encounter%lcollision = .false. end if call system%pl_adds%setup(0, param) diff --git a/src/symba/symba_util.f90 b/src/symba/symba_util.f90 index cf817622e..f4b143c3d 100644 --- a/src/symba/symba_util.f90 +++ b/src/symba/symba_util.f90 @@ -7,39 +7,11 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(symba_classes) s_symba_util +submodule(symba) s_symba_util use swiftest contains - 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) :: nnew - - if (.not. allocated(source)) return - - nnew = count(lsource_mask(1:nsrc)) - if (.not.allocated(arr)) then - allocate(arr(nold+nnew)) - else - call util_resize(arr, nold + nnew) - end if - - arr(nold + 1:nold + nnew) = pack(source(1:nsrc), lsource_mask(1:nsrc)) - - return - end subroutine symba_util_append_arr_kin - - module subroutine symba_util_append_encounter_list(self, source, lsource_mask) !! author: David A. Minton !! @@ -210,20 +182,6 @@ module subroutine symba_util_dealloc_encounter_list(self) end subroutine symba_util_dealloc_encounter_list - module subroutine symba_util_dealloc_kin(self) - !! author: David A. Minton - !! - !! Deallocates all allocatabale arrays - implicit none - ! Arguments - class(symba_kinship), intent(inout) :: self !! SyMBA kinship object - - if (allocated(self%child)) deallocate(self%child) - - return - end subroutine symba_util_dealloc_kin - - module subroutine symba_util_dealloc_merger(self) !! author: David A. Minton !! @@ -250,24 +208,12 @@ module subroutine symba_util_dealloc_pl(self) ! Internals integer(I4B) :: i - if (allocated(self%lcollision)) deallocate(self%lcollision) - if (allocated(self%lencounter)) deallocate(self%lencounter) - if (allocated(self%lmtiny)) deallocate(self%lmtiny) - if (allocated(self%nplenc)) deallocate(self%nplenc) - if (allocated(self%ntpenc)) deallocate(self%ntpenc) if (allocated(self%levelg)) deallocate(self%levelg) if (allocated(self%levelm)) deallocate(self%levelm) if (allocated(self%isperi)) deallocate(self%isperi) if (allocated(self%peri)) deallocate(self%peri) if (allocated(self%atp)) deallocate(self%atp) - if (allocated(self%kin)) then - do i = 1, self%nbody - call self%kin(i)%dealloc() - end do - deallocate(self%kin) - end if - call self%helio_pl%dealloc() return @@ -282,7 +228,6 @@ module subroutine symba_util_dealloc_tp(self) ! Arguments class(symba_tp), intent(inout) :: self !! SyMBA test particle object - if (allocated(self%nplenc)) deallocate(self%nplenc) if (allocated(self%levelg)) deallocate(self%levelg) if (allocated(self%levelm)) deallocate(self%levelm) @@ -292,26 +237,6 @@ module subroutine symba_util_dealloc_tp(self) end subroutine symba_util_dealloc_tp - module subroutine symba_util_fill_arr_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_kin - - module subroutine symba_util_fill_pl(self, inserts, lfill_list) !! author: David A. Minton !! @@ -401,7 +326,7 @@ module subroutine symba_util_flatten_eucl_plpl(self, param) associate(pl => self, nplplm => self%nplplm) npl = int(self%nbody, kind=I8B) select type(param) - class is (symba_parameters) + class is (swiftest_parameters) pl%lmtiny(1:npl) = pl%Gmass(1:npl) < param%GMTINY end select nplm = count(.not. pl%lmtiny(1:npl)) @@ -428,18 +353,6 @@ module subroutine symba_util_final_encounter_list(self) return end subroutine symba_util_final_encounter_list - module subroutine symba_util_final_kin(self) - !! author: David A. Minton - !! - !! Finalize the SyMBA kinship object - deallocates all allocatables - implicit none - ! Argument - type(symba_kinship), intent(inout) :: self !! SyMBA kinship object - - call self%dealloc() - - return - end subroutine symba_util_final_kin module subroutine symba_util_final_merger(self) !! author: David A. Minton @@ -478,9 +391,9 @@ module subroutine symba_util_final_system(self) type(symba_nbody_system), intent(inout) :: self !! SyMBA nbody system object if (allocated(self%pl_adds)) deallocate(self%pl_adds) - if (allocated(self%pltpenc_list)) deallocate(self%pltpenc_list) - if (allocated(self%plplenc_list)) deallocate(self%plplenc_list) - if (allocated(self%plplcollision_list)) deallocate(self%plplcollision_list) + if (allocated(self%pltp_encounter)) deallocate(self%pltp_encounter) + if (allocated(self%plpl_encounter)) deallocate(self%plpl_encounter) + if (allocated(self%plpl_collision)) deallocate(self%plpl_collision) call helio_util_final_system(self%helio_nbody_system) @@ -502,348 +415,6 @@ module subroutine symba_util_final_tp(self) end subroutine symba_util_final_tp - module subroutine symba_util_peri_pl(self, system, param) - !! author: David A. Minton - !! - !! Determine system pericenter passages for planets in SyMBA - !! - !! Adapted from David E. Kaufmann's Swifter routine: symba_peri.f90 - !! Adapted from Hal Levison's Swift routine util_mass_peri.f - implicit none - ! Arguments - class(symba_pl), intent(inout) :: self !! SyMBA massive body object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - ! Internals - integer(I4B) :: i - real(DP) :: vdotr, e - - associate(pl => self, npl => self%nbody) - if (pl%lfirst) then - if (param%qmin_coord == "HELIO") then - do i = 1, npl - if (pl%status(i) == ACTIVE) then - vdotr = dot_product(pl%rh(:,i), pl%vh(:,i)) - if (vdotr > 0.0_DP) then - pl%isperi(i) = 1 - else - pl%isperi(i) = -1 - end if - end if - end do - else - do i = 1, npl - if (pl%status(i) == ACTIVE) then - vdotr = dot_product(pl%rb(:,i), pl%vb(:,i)) - if (vdotr > 0.0_DP) then - pl%isperi(i) = 1 - else - pl%isperi(i) = -1 - end if - end if - end do - end if - else - if (param%qmin_coord == "HELIO") then - do i = 1, npl - if (pl%status(i) == ACTIVE) then - vdotr = dot_product(pl%rh(:,i), pl%vh(:,i)) - if (pl%isperi(i) == -1) then - if (vdotr >= 0.0_DP) then - pl%isperi(i) = 0 - CALL orbel_xv2aeq(pl%mu(i), pl%rh(1,i), pl%rh(2,i), pl%rh(3,i), pl%vh(1,i), pl%vh(2,i), pl%vh(3,i), & - pl%atp(i), e, pl%peri(i)) - end if - else - if (vdotr > 0.0_DP) then - pl%isperi(i) = 1 - else - pl%isperi(i) = -1 - end if - end if - end if - end do - else - do i = 1, npl - if (pl%status(i) == ACTIVE) then - vdotr = dot_product(pl%rb(:,i), pl%vb(:,i)) - if (pl%isperi(i) == -1) then - if (vdotr >= 0.0_DP) then - pl%isperi(i) = 0 - CALL orbel_xv2aeq(system%Gmtot, pl%rb(1,i), pl%rb(2,i), pl%rb(3,i), pl%vb(1,i), pl%vb(2,i), pl%vb(3,i),& - pl%atp(i), e, pl%peri(i)) - end if - else - if (vdotr > 0.0_DP) then - pl%isperi(i) = 1 - else - pl%isperi(i) = -1 - end if - end if - end if - end do - end if - end if - end associate - - return - end subroutine symba_util_peri_pl - - - module subroutine symba_util_rearray_pl(self, system, param) - !! Author: the Purdue Swiftest Team - David A. Minton, Carlisle A. Wishard, Jennifer L.L. Pouplin, and Jacob R. Elliott - !! - !! Clean up the massive body structures to remove discarded bodies and add new bodies - implicit none - ! Arguments - class(symba_pl), intent(inout) :: self !! SyMBA massive body object - class(symba_nbody_system), intent(inout) :: system !! Swiftest nbody system object - class(symba_parameters), intent(inout) :: param !! Current run configuration parameters - ! Internals - class(symba_pl), allocatable :: tmp !! The discarded body list. - integer(I4B) :: i, k, npl, nadd, nencmin, nenc_old, idnew1, idnew2, idold1, idold2 - logical, dimension(:), allocatable :: lmask, ldump_mask - class(symba_plplenc), allocatable :: plplenc_old - logical :: lencounter - integer(I4B), dimension(:), allocatable :: levelg_orig_pl, levelm_orig_pl, levelg_orig_tp, levelm_orig_tp - integer(I4B), dimension(:), allocatable :: nplenc_orig_pl, nplenc_orig_tp, ntpenc_orig_pl - - associate(pl => self, pl_adds => system%pl_adds) - - npl = pl%nbody - nadd = pl_adds%nbody - if (npl == 0) return - ! Deallocate any temporary variables - if (allocated(pl%rbeg)) deallocate(pl%rbeg) - if (allocated(pl%xend)) deallocate(pl%xend) - - ! Remove the discards and destroy the list, as the system already tracks pl_discards elsewhere - allocate(lmask(npl)) - lmask(1:npl) = pl%ldiscard(1:npl) - if (count(lmask(:)) > 0) then - allocate(tmp, mold=self) - call pl%spill(tmp, lspill_list=lmask, ldestructive=.true.) - npl = pl%nbody - call tmp%setup(0,param) - deallocate(tmp) - deallocate(lmask) - end if - - ! Store the original plplenc list so we don't remove any of the original encounters - nenc_old = system%plplenc_list%nenc - if (nenc_old > 0) then - allocate(plplenc_old, source=system%plplenc_list) - call plplenc_old%copy(system%plplenc_list) - end if - - ! Add in any new bodies - if (nadd > 0) then - ! Append the adds to the main pl object - call pl%append(pl_adds, lsource_mask=[(.true., i=1, nadd)]) - - allocate(ldump_mask(npl+nadd)) ! This mask is used only to append the original Fortran binary particle.dat file with new bodies. This is ignored for NetCDF output - ldump_mask(1:npl) = .false. - ldump_mask(npl+1:npl+nadd) = pl%status(npl+1:npl+nadd) == NEW_PARTICLE - npl = pl%nbody - else - allocate(ldump_mask(npl)) - ldump_mask(:) = .false. - end if - - ! Reset all of the status flags for this body - pl%status(1:npl) = ACTIVE - do i = 1, npl - call pl%info(i)%set_value(status="ACTIVE") - end do - pl%ldiscard(1:npl) = .false. - pl%lcollision(1:npl) = .false. - pl%lmask(1:npl) = .true. - - pl%lmtiny(1:npl) = pl%Gmass(1:npl) < param%GMTINY - where(pl%lmtiny(1:npl)) - pl%info(1:npl)%particle_type = PL_TINY_TYPE_NAME - elsewhere - pl%info(1:npl)%particle_type = PL_TYPE_NAME - end where - - call pl%write_info(param%system_history%nc, param) - deallocate(ldump_mask) - - ! Reindex the new list of bodies - call pl%sort("mass", ascending=.false.) - call pl%flatten(param) - - ! Reset the kinship trackers - call pl%reset_kinship([(i, i=1, npl)]) - - ! Re-build the zero-level encounter list, being sure to save the original level information for all bodies - allocate(levelg_orig_pl, source=pl%levelg) - allocate(levelm_orig_pl, source=pl%levelm) - allocate(nplenc_orig_pl, source=pl%nplenc) - lencounter = pl%encounter_check(param, system, param%dt, system%irec) - if (system%tp%nbody > 0) then - select type(tp => system%tp) - class is (symba_tp) - allocate(ntpenc_orig_pl, source=pl%ntpenc) - allocate(levelg_orig_tp, source=tp%levelg) - allocate(levelm_orig_tp, source=tp%levelm) - allocate(nplenc_orig_tp, source=tp%nplenc) - lencounter = tp%encounter_check(param, system, param%dt, system%irec) - call move_alloc(levelg_orig_tp, tp%levelg) - call move_alloc(levelm_orig_tp, tp%levelm) - call move_alloc(nplenc_orig_tp, tp%nplenc) - call move_alloc(ntpenc_orig_pl, pl%ntpenc) - end select - end if - call move_alloc(levelg_orig_pl, pl%levelg) - call move_alloc(levelm_orig_pl, pl%levelm) - call move_alloc(nplenc_orig_pl, pl%nplenc) - - ! Re-index the encounter list as the index values may have changed - if (nenc_old > 0) then - nencmin = min(system%plplenc_list%nenc, plplenc_old%nenc) - system%plplenc_list%nenc = nencmin - do k = 1, nencmin - idnew1 = system%plplenc_list%id1(k) - idnew2 = system%plplenc_list%id2(k) - idold1 = plplenc_old%id1(k) - idold2 = plplenc_old%id2(k) - if ((idnew1 == idold1) .and. (idnew2 == idold2)) then - ! This is an encounter we already know about, so save the old information - system%plplenc_list%lvdotr(k) = plplenc_old%lvdotr(k) - system%plplenc_list%lclosest(k) = plplenc_old%lclosest(k) - system%plplenc_list%status(k) = plplenc_old%status(k) - system%plplenc_list%r1(:,k) = plplenc_old%r1(:,k) - system%plplenc_list%r2(:,k) = plplenc_old%r2(:,k) - system%plplenc_list%v1(:,k) = plplenc_old%v1(:,k) - system%plplenc_list%v2(:,k) = plplenc_old%v2(:,k) - system%plplenc_list%tcollision(k) = plplenc_old%tcollision(k) - system%plplenc_list%level(k) = plplenc_old%level(k) - else if (((idnew1 == idold2) .and. (idnew2 == idold1))) then - ! This is an encounter we already know about, but with the order reversed, so save the old information - system%plplenc_list%lvdotr(k) = plplenc_old%lvdotr(k) - system%plplenc_list%lclosest(k) = plplenc_old%lclosest(k) - system%plplenc_list%status(k) = plplenc_old%status(k) - system%plplenc_list%r1(:,k) = plplenc_old%r2(:,k) - system%plplenc_list%r2(:,k) = plplenc_old%r1(:,k) - system%plplenc_list%v1(:,k) = plplenc_old%v2(:,k) - system%plplenc_list%v2(:,k) = plplenc_old%v1(:,k) - system%plplenc_list%tcollision(k) = plplenc_old%tcollision(k) - system%plplenc_list%level(k) = plplenc_old%level(k) - end if - system%plplenc_list%index1(k) = findloc(pl%id(1:npl), system%plplenc_list%id1(k), dim=1) - system%plplenc_list%index2(k) = findloc(pl%id(1:npl), system%plplenc_list%id2(k), dim=1) - end do - if (allocated(lmask)) deallocate(lmask) - allocate(lmask(nencmin)) - nenc_old = nencmin - if (any(system%plplenc_list%index1(1:nencmin) == 0) .or. any(system%plplenc_list%index2(1:nencmin) == 0)) then - lmask(:) = system%plplenc_list%index1(1:nencmin) /= 0 .and. system%plplenc_list%index2(1:nencmin) /= 0 - else - return - end if - nencmin = count(lmask(:)) - system%plplenc_list%nenc = nencmin - if (nencmin > 0) then - system%plplenc_list%index1(1:nencmin) = pack(system%plplenc_list%index1(1:nenc_old), lmask(1:nenc_old)) - system%plplenc_list%index2(1:nencmin) = pack(system%plplenc_list%index2(1:nenc_old), lmask(1:nenc_old)) - system%plplenc_list%id1(1:nencmin) = pack(system%plplenc_list%id1(1:nenc_old), lmask(1:nenc_old)) - system%plplenc_list%id2(1:nencmin) = pack(system%plplenc_list%id2(1:nenc_old), lmask(1:nenc_old)) - system%plplenc_list%lvdotr(1:nencmin) = pack(system%plplenc_list%lvdotr(1:nenc_old), lmask(1:nenc_old)) - system%plplenc_list%lclosest(1:nencmin) = pack(system%plplenc_list%lclosest(1:nenc_old), lmask(1:nenc_old)) - system%plplenc_list%status(1:nencmin) = pack(system%plplenc_list%status(1:nenc_old), lmask(1:nenc_old)) - system%plplenc_list%tcollision(1:nencmin) = pack(system%plplenc_list%tcollision(1:nenc_old), lmask(1:nenc_old)) - system%plplenc_list%level(1:nencmin) = pack(system%plplenc_list%level(1:nenc_old), lmask(1:nenc_old)) - do i = 1, NDIM - system%plplenc_list%r1(i, 1:nencmin) = pack(system%plplenc_list%r1(i, 1:nenc_old), lmask(1:nenc_old)) - system%plplenc_list%r2(i, 1:nencmin) = pack(system%plplenc_list%r2(i, 1:nenc_old), lmask(1:nenc_old)) - system%plplenc_list%v1(i, 1:nencmin) = pack(system%plplenc_list%v1(i, 1:nenc_old), lmask(1:nenc_old)) - system%plplenc_list%v2(i, 1:nencmin) = pack(system%plplenc_list%v2(i, 1:nenc_old), lmask(1:nenc_old)) - end do - end if - end if - end associate - - return - end subroutine symba_util_rearray_pl - - - module subroutine symba_util_reset_kinship(self, idx) - !! author: David A. Minton - !! - !! Resets the kinship status of bodies. - !! - implicit none - class(symba_pl), intent(inout) :: self !! SyMBA massive body object - integer(I4B), dimension(:), intent(in) :: idx !! Index array of bodies to reset - ! Internals - integer(I4B) :: i, j - - self%kin(idx(:))%parent = idx(:) - self%kin(idx(:))%nchild = 0 - do j = 1, size(idx(:)) - i = idx(j) - if (allocated(self%kin(i)%child)) deallocate(self%kin(i)%child) - end do - - return - end subroutine symba_util_reset_kinship - - - module subroutine symba_util_resize_arr_kin(arr, nnew) - !! author: David A. Minton - !! - !! Resizes an array component of type character string. Array will only be resized if has previously been allocated. Passing nnew = 0 will deallocate. - implicit none - ! Arguments - type(symba_kinship), dimension(:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size - ! Internals - type(symba_kinship), dimension(:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated - integer(I4B) :: nold !! Old size - - if (nnew < 0) return - - if (nnew == 0) then - if (allocated(arr)) deallocate(arr) - return - end if - - if (allocated(arr)) then - nold = size(arr) - else - nold = 0 - end if - - allocate(tmp(nnew)) - if (nnew > nold) then - tmp(1:nold) = arr(1:nold) - else - tmp(1:nnew) = arr(1:nnew) - end if - call move_alloc(tmp, arr) - - return - end subroutine symba_util_resize_arr_kin - - - module subroutine symba_util_resize_merger(self, nnew) - !! author: David A. Minton - !! - !! Checks the current size of a SyMBA merger list against the requested size and resizes it if it is too small. - implicit none - ! Arguments - class(symba_merger), intent(inout) :: self !! SyMBA massive body object - integer(I4B), intent(in) :: nnew !! New size neded - - call util_resize(self%ncomp, nnew) - - call symba_util_resize_pl(self, nnew) - - return - end subroutine symba_util_resize_merger - - module subroutine symba_util_resize_pl(self, nnew) !! author: David A. Minton !! @@ -853,17 +424,11 @@ module subroutine symba_util_resize_pl(self, nnew) class(symba_pl), intent(inout) :: self !! SyMBA massive body object integer(I4B), intent(in) :: nnew !! New size neded - call util_resize(self%lcollision, nnew) - call util_resize(self%lencounter, nnew) - call util_resize(self%lmtiny, nnew) - call util_resize(self%nplenc, nnew) - call util_resize(self%ntpenc, nnew) call util_resize(self%levelg, nnew) call util_resize(self%levelm, nnew) call util_resize(self%isperi, nnew) call util_resize(self%peri, nnew) call util_resize(self%atp, nnew) - call util_resize(self%kin, nnew) call util_resize_pl(self, nnew) @@ -879,7 +444,6 @@ module subroutine symba_util_resize_tp(self, nnew) class(symba_tp), intent(inout) :: self !! SyMBA test particle object integer(I4B), intent(in) :: nnew !! New size neded - call util_resize(self%nplenc, nnew) call util_resize(self%levelg, nnew) call util_resize(self%levelm, nnew) @@ -1006,35 +570,6 @@ module subroutine symba_util_sort_tp(self, sortby, ascending) end subroutine symba_util_sort_tp - - module subroutine symba_util_sort_rearrange_arr_kin(arr, ind, n) - !! author: David A. Minton - !! - !! Rearrange a single array of particle kinship type in-place from an index list. - implicit none - ! Arguments - type(symba_kinship), dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange - ! Internals - type(symba_kinship), dimension(:), allocatable :: tmp !! Temporary copy of array used during rearrange operation - integer(I4B) :: i,j - - if (.not. allocated(arr) .or. n <= 0) return - allocate(tmp, source=arr) - tmp(1:n) = arr(ind(1:n)) - - do i = 1, n - do j = 1, tmp(i)%nchild - tmp(i)%child(j) = ind(tmp(i)%child(j)) - end do - end do - - call move_alloc(tmp, arr) - return - end subroutine symba_util_sort_rearrange_arr_kin - - module subroutine symba_util_sort_rearrange_pl(self, ind) !! author: David A. Minton !! @@ -1046,18 +581,8 @@ module subroutine symba_util_sort_rearrange_pl(self, ind) integer(I4B), dimension(:), intent(in) :: ind !! Index array used to restructure the body (should contain all 1:n index values in the desired order) associate(pl => self, npl => self%nbody) - call util_sort_rearrange(pl%lcollision, ind, npl) - call util_sort_rearrange(pl%lencounter, ind, npl) - call util_sort_rearrange(pl%lmtiny, ind, npl) - call util_sort_rearrange(pl%nplenc, ind, npl) - call util_sort_rearrange(pl%ntpenc, ind, npl) call util_sort_rearrange(pl%levelg, ind, npl) call util_sort_rearrange(pl%levelm, ind, npl) - call util_sort_rearrange(pl%isperi, ind, npl) - call util_sort_rearrange(pl%peri, ind, npl) - call util_sort_rearrange(pl%atp, ind, npl) - call util_sort_rearrange(pl%kin, ind, npl) - call util_sort_rearrange_pl(pl,ind) end associate @@ -1087,46 +612,6 @@ module subroutine symba_util_sort_rearrange_tp(self, ind) end subroutine symba_util_sort_rearrange_tp - 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 - ! Internals - integer(I4B) :: nspill, nkeep, nlist - type(symba_kinship), dimension(:), allocatable :: tmp - - nkeep = count(.not.lspill_list(:)) - nspill = count(lspill_list(:)) - nlist = size(lspill_list(:)) - - if (.not.allocated(keeps) .or. nspill == 0) return - if (.not.allocated(discards)) then - allocate(discards(nspill)) - else if (size(discards) /= nspill) then - deallocate(discards) - allocate(discards(nspill)) - end if - - discards(:) = pack(keeps(1:nlist), lspill_list(1:nlist)) - if (ldestructive) then - if (nkeep > 0) then - allocate(tmp(nkeep)) - tmp(:) = pack(keeps(1:nlist), .not. lspill_list(1:nlist)) - call move_alloc(tmp, keeps) - 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) @@ -1173,7 +658,7 @@ module subroutine symba_util_spill_encounter_list(self, discards, lspill_list, l !! author: David A. Minton !! !! Move spilled (discarded) SyMBA encounter structure from active list to discard list - !! Note: Because the symba_plplenc currently does not contain any additional variable components, this method can recieve it as an input as well. + !! Note: Because the plpl_encounter currently does not contain any additional variable components, this method can recieve it as an input as well. implicit none ! Arguments class(symba_encounter), intent(inout) :: self !! SyMBA pl-tp encounter list diff --git a/src/tides/tides_getacch_pl.f90 b/src/tides/tides_getacch_pl.f90 index c37e84b88..aed941e8f 100644 --- a/src/tides/tides_getacch_pl.f90 +++ b/src/tides/tides_getacch_pl.f90 @@ -1,4 +1,4 @@ -submodule(swiftest_classes) s_tides_kick_getacch +submodule(base) s_tides_kick_getacch use swiftest contains @@ -17,8 +17,8 @@ module subroutine tides_kick_getacch_pl(self, system) !! Applications to Kepler-62. A&A 583, A116. https://doi.org/10.1051/0004-6361/201525909 implicit none ! Arguments - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object + class(base_object), intent(inout) :: self !! Swiftest massive body object + class(base_nbody_system), intent(inout) :: system !! Swiftest nbody system object ! Internals integer(I4B) :: i real(DP) :: rmag, vmag diff --git a/src/tides/tides_spin_step.f90 b/src/tides/tides_spin_step.f90 index ee4309eb6..3fadfc704 100644 --- a/src/tides/tides_spin_step.f90 +++ b/src/tides/tides_spin_step.f90 @@ -1,11 +1,11 @@ -submodule(swiftest_classes) s_tides_step_spin +submodule(base) s_tides_step_spin use swiftest type, extends(lambda_obj_tvar) :: tides_derivs_func !! Base class for an lambda function object. This object takes no additional arguments other than the dependent variable x, an array of real numbers procedure(tidederiv), pointer, nopass :: lambdaptr_tides_deriv real(DP), dimension(:,:), allocatable :: rbeg - real(DP), dimension(:,:), allocatable :: xend + real(DP), dimension(:,:), allocatable :: rend real(DP) :: dt contains generic :: init => tides_derivs_init @@ -16,14 +16,14 @@ module procedure tides_derivs_init end interface abstract interface - function tidederiv(x, t, dt, rbeg, xend) result(y) + function tidederiv(x, t, dt, rbeg, rend) result(y) ! Template for a 0 argument function - import DP, swiftest_nbody_system + import DP, base_nbody_system real(DP), dimension(:), intent(in) :: x real(DP), intent(in) :: t real(DP), intent(in) :: dt real(DP), dimension(:,:), intent(in) :: rbeg - real(DP), dimension(:,:), intent(in) :: xend + real(DP), dimension(:,:), intent(in) :: rend real(DP), dimension(:), allocatable :: y end function end interface @@ -36,8 +36,8 @@ module subroutine tides_step_spin_system(self, param, t, dt) !! Integrates the spin equations for central and massive bodies of the system subjected to tides. implicit none ! Arguments - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters + class(base_nbody_system), intent(inout) :: self !! Swiftest nbody system object + class(base_parameters), intent(in) :: param !! Current run configuration parameters real(DP), intent(in) :: t !! Simulation time real(DP), intent(in) :: dt !! Current stepsize ! Internals @@ -51,7 +51,7 @@ module subroutine tides_step_spin_system(self, param, t, dt) rot0 = [pack(pl%rot(:,1:npl),.true.), pack(cb%rot(:),.true.)] ! Use this space call the ode_solver, passing tides_spin_derivs as the function: subdt = dt / 20._DP - !rot1(:) = util_solve_rkf45(lambda_obj(tides_spin_derivs, subdt, pl%rbeg, pl%xend), rot0, dt, subdt tol) + !rot1(:) = util_solve_rkf45(lambda_obj(tides_spin_derivs, subdt, pl%rbeg, pl%rend), rot0, dt, subdt tol) ! Recover with unpack !pl%rot(:,1:npl) = unpack(rot1... !cb%rot(:) = unpack(rot1... @@ -61,7 +61,7 @@ module subroutine tides_step_spin_system(self, param, t, dt) end subroutine tides_step_spin_system - function tides_spin_derivs(rot_pl_cb, t, dt, rbeg, xend) result(drot) !! Need to add more arguments so we can pull in mass, radius, Ip, J2, etc... + function tides_spin_derivs(rot_pl_cb, t, dt, rbeg, rend) result(drot) !! Need to add more arguments so we can pull in mass, radius, Ip, J2, etc... !! author: Jennifer L.L. Pouplin and David A. Minton !! !! function used to calculate the derivatives that are fed to the ODE solver @@ -71,7 +71,7 @@ function tides_spin_derivs(rot_pl_cb, t, dt, rbeg, xend) result(drot) !! Need to real(DP), intent(in) :: t !! Current time, which is used to interpolate the massive body positions real(DP), intent(in) :: dt !! Total step size real(DP), dimension(:,:), intent(in) :: rbeg - real(DP), dimension(:,:), intent(in) :: xend + real(DP), dimension(:,:), intent(in) :: rend ! Internals real(DP), dimension(:,:), allocatable :: drot real(DP), dimension(:), allocatable :: flatrot @@ -85,7 +85,7 @@ function tides_spin_derivs(rot_pl_cb, t, dt, rbeg, xend) result(drot) !! Need to allocate(drot, mold=rot_pl_cb) drot(:,:) = 0.0_DP do i = 1,n-1 - xinterp(:) = rbeg(:,i) + t / dt * (xend(:,i) - rbeg(:,i)) + xinterp(:) = rbeg(:,i) + t / dt * (rend(:,i) - rbeg(:,i)) ! Calculate Ncb and Npl as a function of xinterp !drot(:,i) = -Mcb / (Mcb + Mpl(i)) * (N_Tpl + N_Rpl) !drot(:,n) = drot(:,n) - Mcb / (Mcb + Mpl(i) * (N_Tcb + N_Rcb) @@ -104,7 +104,7 @@ function tides_derivs_eval(self, x, t) result(y) ! Result real(DP), dimension(:), allocatable :: y if (associated(self%lambdaptr_tides_deriv)) then - y = self%lambdaptr_tides_deriv(x, t, self%dt, self%rbeg, self%xend) + y = self%lambdaptr_tides_deriv(x, t, self%dt, self%rbeg, self%rend) else error stop "Lambda function was not initialized" end if @@ -112,19 +112,19 @@ function tides_derivs_eval(self, x, t) result(y) return end function tides_derivs_eval - function tides_derivs_init(lambda, dt, rbeg, xend) result(f) + function tides_derivs_init(lambda, dt, rbeg, rend) result(f) implicit none ! Arguments procedure(tidederiv) :: lambda real(DP), intent(in) :: dt real(DP), dimension(:,:), intent(in) :: rbeg - real(DP), dimension(:,:), intent(in) :: xend + real(DP), dimension(:,:), intent(in) :: rend ! Result type(tides_derivs_func) :: f f%lambdaptr_tides_deriv => lambda f%dt = dt allocate(f%rbeg, source = rbeg) - allocate(f%xend, source = xend) + allocate(f%rend, source = rend) return end function tides_derivs_init diff --git a/src/user/user_getacch.f90 b/src/user/user_getacch.f90 index 0ba61bd8d..deb54e93f 100644 --- a/src/user/user_getacch.f90 +++ b/src/user/user_getacch.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(swiftest_classes) s_user_kick_getacch +submodule(base) s_user_kick_getacch use swiftest contains module subroutine user_kick_getacch_body(self, system, param, t, lbeg) @@ -18,11 +18,11 @@ module subroutine user_kick_getacch_body(self, system, param, t, lbeg) !! Adapted from David E. Kaufmann's Swifter routine whm_user_kick_getacch.f90 implicit none ! Arguments - class(swiftest_body), intent(inout) :: self !! Swiftest massive body particle data structure - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody_system_object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters user parameters - 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 ste + class(swiftest_body), intent(inout) :: self !! Swiftest massive body particle data structure + class(swiftest_system), intent(inout) :: system !! Swiftest nbody_system_object + class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters user parameters + 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 ste return end subroutine user_kick_getacch_body diff --git a/src/util/util_append.f90 b/src/util/util_append.f90 deleted file mode 100644 index 7470bace4..000000000 --- a/src/util/util_append.f90 +++ /dev/null @@ -1,304 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule (swiftest_classes) s_util_append - use swiftest -contains - - 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. - implicit none - ! 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) :: nnew - - if (.not. allocated(source)) return - - nnew = count(lsource_mask(1:nsrc)) - if (.not.allocated(arr)) then - allocate(arr(nold+nnew)) - else - call util_resize(arr, nold + nnew) - end if - - arr(nold + 1:nold + nnew) = pack(source(1:nsrc), lsource_mask(1:nsrc)) - - return - end subroutine util_append_arr_char_string - - - 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. - implicit none - ! 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) :: nnew - - if (.not. allocated(source)) return - - nnew = count(lsource_mask(1:nsrc)) - if (.not.allocated(arr)) then - allocate(arr(nold+nnew)) - else - call util_resize(arr, nold + nnew) - end if - - arr(nold + 1:nold + nnew) = pack(source(1:nsrc), lsource_mask(1:nsrc)) - - return - end subroutine util_append_arr_DP - - - 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. - implicit none - ! 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) :: nnew - - if (.not. allocated(source)) return - - nnew = count(lsource_mask(1:nsrc)) - if (.not.allocated(arr)) then - allocate(arr(NDIM,nold+nnew)) - else - call util_resize(arr, nold + nnew) - end if - - arr(1, nold + 1:nold + nnew) = pack(source(1,1:nsrc), lsource_mask(1:nsrc)) - arr(2, nold + 1:nold + nnew) = pack(source(2,1:nsrc), lsource_mask(1:nsrc)) - arr(3, nold + 1:nold + nnew) = pack(source(3,1:nsrc), lsource_mask(1:nsrc)) - - return - end subroutine util_append_arr_DPvec - - - 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. - implicit none - ! 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) :: nnew - - if (.not. allocated(source)) return - - nnew = count(lsource_mask(1:nsrc)) - if (.not.allocated(arr)) then - allocate(arr(nold+nnew)) - else - call util_resize(arr, nold + nnew) - end if - - arr(nold + 1:nold + nnew) = pack(source(1:nsrc), lsource_mask(1:nsrc)) - - return - end subroutine util_append_arr_I4B - - - module subroutine 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(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: arr !! Destination array - type(swiftest_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) :: nnew, i - integer(I4B), dimension(:), allocatable :: idx - - if (.not. allocated(source)) return - - nnew = count(lsource_mask(1:nsrc)) - if (.not.allocated(arr)) then - allocate(arr(nold+nnew)) - else - call util_resize(arr, nold + nnew) - end if - - allocate(idx(nnew)) - - idx = pack([(i, i = 1, nsrc)], lsource_mask(1:nsrc)) - - call util_copy_particle_info_arr(source(1:nsrc), arr(nold+1:nold+nnew), idx) - - return - end subroutine util_append_arr_info - - - 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. - implicit none - ! 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) :: nnew - - if (.not. allocated(source)) return - - nnew = count(lsource_mask(1:nsrc)) - if (.not.allocated(arr)) then - allocate(arr(nold+nnew)) - else - call util_resize(arr, nold + nnew) - end if - - arr(nold + 1:nold + nnew) = pack(source(1:nsrc), lsource_mask(1:nsrc)) - - return - end subroutine util_append_arr_logical - - - module subroutine util_append_body(self, source, lsource_mask) - !! author: David A. Minton - !! - !! Append components from one Swiftest body object to another. - !! This method will automatically resize the destination body if it is too small - implicit none - ! Arguments - class(swiftest_body), intent(inout) :: self !! Swiftest body object - class(swiftest_body), intent(in) :: source !! Source object to append - logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to - ! Internals - integer(I4B) :: nold, nsrc, nnew - - nold = self%nbody - nsrc = source%nbody - nnew = count(lsource_mask(1:nsrc)) - - call util_append(self%info, source%info, 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%rh, source%rh, nold, nsrc, lsource_mask) - call util_append(self%vh, source%vh, nold, nsrc, lsource_mask) - call util_append(self%rb, source%rb, 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) - - self%nbody = nold + nnew - - return - end subroutine util_append_body - - - module subroutine util_append_pl(self, source, lsource_mask) - !! author: David A. Minton - !! - !! Append components from one Swiftest body object to another. - !! This method will automatically resize the destination body if it is too small - implicit none - ! Arguments - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_body), intent(in) :: source !! Source object to append - logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to - - select type(source) - class is (swiftest_pl) - associate(nold => self%nbody, nsrc => source%nbody) - 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%renc, source%renc, nold, nsrc, lsource_mask) - call util_append(self%radius, source%radius, nold, nsrc, lsource_mask) - call util_append(self%rbeg, source%rbeg, 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) - - if (allocated(self%k_plpl)) deallocate(self%k_plpl) - - call util_append_body(self, source, lsource_mask) - end associate - class default - write(*,*) "Invalid object passed to the append method. Source must be of class swiftest_pl or its descendents" - call util_exit(FAILURE) - end select - - return - end subroutine util_append_pl - - - module subroutine util_append_tp(self, source, lsource_mask) - !! author: David A. Minton - !! - !! Append components from one Swiftest body object to another. - !! This method will automatically resize the destination body if it is too small - implicit none - ! Arguments - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - class(swiftest_body), intent(in) :: source !! Source object to append - logical, dimension(:), intent(in) :: lsource_mask !! Logical mask indicating which elements to append to - - select type(source) - class is (swiftest_tp) - associate(nold => self%nbody, nsrc => source%nbody) - 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_body(self, source, 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) - end select - - return - end subroutine util_append_tp - -end submodule s_util_append \ No newline at end of file diff --git a/src/util/util_coord.f90 b/src/util/util_coord.f90 deleted file mode 100644 index 78c2eca83..000000000 --- a/src/util/util_coord.f90 +++ /dev/null @@ -1,309 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule(swiftest_classes) s_util_coord - use swiftest -contains - - module subroutine util_coord_h2b_pl(self, cb) - !! author: David A. Minton - !! - !! Convert massive bodies from heliocentric to barycentric coordinates (position and velocity) - !! - !! Adapted from David E. Kaufmann's Swifter routine coord_h2b.f90 - !! Adapted from Hal Levison's Swift routine coord_h2b.f - implicit none - ! Arguments - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object - ! Internals - integer(I4B) :: i - real(DP) :: Gmtot - real(DP), dimension(NDIM) :: xtmp, vtmp - - if (self%nbody == 0) return - associate(pl => self, npl => self%nbody) - Gmtot = cb%Gmass - xtmp(:) = 0.0_DP - vtmp(:) = 0.0_DP - do i = 1, npl - if (pl%status(i) == INACTIVE) cycle - Gmtot = Gmtot + pl%Gmass(i) - xtmp(:) = xtmp(:) + pl%Gmass(i) * pl%rh(:,i) - vtmp(:) = vtmp(:) + pl%Gmass(i) * pl%vh(:,i) - end do - cb%rb(:) = -xtmp(:) / Gmtot - cb%vb(:) = -vtmp(:) / Gmtot - do i = 1, npl - if (pl%status(i) == INACTIVE) cycle - pl%rb(:,i) = pl%rh(:,i) + cb%rb(:) - pl%vb(:,i) = pl%vh(:,i) + cb%vb(:) - end do - end associate - - return - end subroutine util_coord_h2b_pl - - - module subroutine util_coord_h2b_tp(self, cb) - !! author: David A. Minton - !! - !! Convert test particles from heliocentric to barycentric coordinates (position and velocity) - !! - !! Adapted from David E. Kaufmann's Swifter routine coord_h2b_tp.f90 - !! Adapted from Hal Levison's Swift routine coord_h2b_tp.f - implicit none - ! Arguments - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - class(swiftest_cb), intent(in) :: cb !! Swiftest central body object - ! Internals - integer(I4B) :: i - - if (self%nbody == 0) return - associate(tp => self, ntp => self%nbody) - do concurrent (i = 1:ntp, tp%status(i) /= INACTIVE) - tp%rb(:, i) = tp%rh(:, i) + cb%rb(:) - tp%vb(:, i) = tp%vh(:, i) + cb%vb(:) - end do - end associate - - return - end subroutine util_coord_h2b_tp - - - module subroutine util_coord_b2h_pl(self, cb) - !! author: David A. Minton - !! - !! Convert massive bodies from barycentric to heliocentric coordinates (position and velocity) - !! - !! Adapted from David E. Kaufmann's Swifter routine coord_b2h.f90 - !! Adapted from Hal Levison's Swift routine coord_b2h.f - implicit none - ! Arguments - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object - ! Internals - integer(I4B) :: i - - if (self%nbody == 0) return - - associate(pl => self, npl => self%nbody) - do concurrent (i = 1:npl, pl%status(i) /= INACTIVE) - pl%rh(:, i) = pl%rb(:, i) - cb%rb(:) - pl%vh(:, i) = pl%vb(:, i) - cb%vb(:) - end do - end associate - - return - end subroutine util_coord_b2h_pl - - - module subroutine util_coord_b2h_tp(self, cb) - !! author: David A. Minton - !! - !! Convert test particles from barycentric to heliocentric coordinates (position and velocity) - !! - !! Adapted from David E. Kaufmann's Swifter routine coord_b2h_tp.f90 - !! Adapted from Hal Levison's Swift routine coord_b2h_tp.f - implicit none - ! Arguments - class(swiftest_tp), intent(inout) :: self !! Swiftest massive body object - class(swiftest_cb), intent(in) :: cb !! Swiftest central body object - ! Internals - integer(I4B) :: i - - if (self%nbody == 0) return - - associate(tp => self, ntp => self%nbody) - do concurrent(i = 1:ntp, tp%status(i) /= INACTIVE) - tp%rh(:, i) = tp%rb(:, i) - cb%rb(:) - tp%vh(:, i) = tp%vb(:, i) - cb%vb(:) - end do - end associate - - return - end subroutine util_coord_b2h_tp - - - module subroutine util_coord_vb2vh_pl(self, cb) - !! author: David A. Minton - !! - !! Convert massive bodies from barycentric to heliocentric coordinates (velocity only) - !! - !! Adapted from David E. Kaufmann's Swifter routine coord_vb2vh.f90 - !! Adapted from Hal Levison's Swift routine coord_vb2vh.f - implicit none - ! Arguments - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object - ! Internals - integer(I4B) :: i - - if (self%nbody == 0) return - - associate(pl => self, npl => self%nbody) - cb%vb(:) = 0.0_DP - do i = npl, 1, -1 - cb%vb(:) = cb%vb(:) - pl%Gmass(i) * pl%vb(:, i) / cb%Gmass - end do - do concurrent(i = 1:npl) - pl%vh(:, i) = pl%vb(:, i) - cb%vb(:) - end do - end associate - - return - end subroutine util_coord_vb2vh_pl - - - module subroutine util_coord_vb2vh_tp(self, vbcb) - !! author: David A. Minton - !! - !! Convert test particles from barycentric to heliocentric coordinates (velocity only) - !! - !! Adapted from David E. Kaufmann's Swifter routine coord_vb2vh_tp.f90 - !! Adapted from Hal Levison's Swift routine coord_vb2h_tp.f - implicit none - ! Arguments - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - real(DP), dimension(:), intent(in) :: vbcb !! Barycentric velocity of the central body - - if (self%nbody == 0) return - - associate(tp => self, ntp => self%nbody) - where (tp%lmask(1:ntp)) - tp%vh(1, 1:ntp) = tp%vb(1, 1:ntp) - vbcb(1) - tp%vh(2, 1:ntp) = tp%vb(2, 1:ntp) - vbcb(2) - tp%vh(3, 1:ntp) = tp%vb(3, 1:ntp) - vbcb(3) - end where - end associate - - return - end subroutine util_coord_vb2vh_tp - - - module subroutine util_coord_vh2vb_pl(self, cb) - !! author: David A. Minton - !! - !! Convert massive bodies from heliocentric to barycentric coordinates (velocity only) - !! - !! Adapted from David E. Kaufmann's Swifter routine coord_vh2vb.f90 - !! Adapted from Hal Levison's Swift routine coord_vh2b.f - implicit none - ! Arguments - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object - ! Internals - integer(I4B) :: i - real(DP) :: Gmtot - - if (self%nbody == 0) return - - associate(pl => self, npl => self%nbody) - Gmtot = cb%Gmass + sum(pl%Gmass(1:npl)) - cb%vb(:) = 0.0_DP - do i = 1, npl - cb%vb(:) = cb%vb(:) - pl%Gmass(i) * pl%vh(:, i) - end do - cb%vb(:) = cb%vb(:) / Gmtot - do concurrent(i = 1:npl) - pl%vb(:, i) = pl%vh(:, i) + cb%vb(:) - end do - end associate - - return - end subroutine util_coord_vh2vb_pl - - - module subroutine util_coord_vh2vb_tp(self, vbcb) - !! author: David A. Minton - !! - !! Convert test particles from heliocentric to barycentric coordinates (velocity only) - !! - !! Adapted from David E. Kaufmann's Swifter routine coord_vh2vb_tp.f90 - !! Adapted from Hal Levison's Swift routine coord_vh2b_tp.f - implicit none - ! Arguments - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - real(DP), dimension(:), intent(in) :: vbcb !! Barycentric velocity of the central body - - if (self%nbody == 0) return - - associate(tp => self, ntp => self%nbody) - where (tp%lmask(1:ntp)) - tp%vb(1, 1:ntp) = tp%vh(1, 1:ntp) + vbcb(1) - tp%vb(2, 1:ntp) = tp%vh(2, 1:ntp) + vbcb(2) - tp%vb(3, 1:ntp) = tp%vh(3, 1:ntp) + vbcb(3) - end where - end associate - - return - end subroutine util_coord_vh2vb_tp - - - module subroutine util_coord_rh2rb_pl(self, cb) - !! author: David A. Minton - !! - !! Convert position vectors of massive bodies from heliocentric to barycentric coordinates (position only) - !! - !! Adapted from David E. Kaufmann's Swifter routine coord_h2b.f90 - !! Adapted from Hal Levison's Swift routine coord_h2b.f - implicit none - ! Arguments - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object - ! Internals - integer(I4B) :: i - real(DP) :: Gmtot - real(DP), dimension(NDIM) :: xtmp - - if (self%nbody == 0) return - associate(pl => self, npl => self%nbody) - Gmtot = cb%Gmass - xtmp(:) = 0.0_DP - do i = 1, npl - if (pl%status(i) == INACTIVE) cycle - Gmtot = Gmtot + pl%Gmass(i) - xtmp(:) = xtmp(:) + pl%Gmass(i) * pl%rh(:,i) - end do - cb%rb(:) = -xtmp(:) / Gmtot - do i = 1, npl - if (pl%status(i) == INACTIVE) cycle - pl%rb(:,i) = pl%rh(:,i) + cb%rb(:) - end do - end associate - - return - end subroutine util_coord_rh2rb_pl - - - module subroutine util_coord_rh2rb_tp(self, cb) - !! author: David A. Minton - !! - !! Convert test particles from heliocentric to barycentric coordinates (position only) - !! - !! Adapted from David E. Kaufmann's Swifter routine coord_h2b_tp.f90 - !! Adapted from Hal Levison's Swift routine coord_h2b_tp.f - implicit none - ! Arguments - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - class(swiftest_cb), intent(in) :: cb !! Swiftest central body object - ! Internals - integer(I4B) :: i - - if (self%nbody == 0) return - associate(tp => self, ntp => self%nbody) - do concurrent (i = 1:ntp, tp%status(i) /= INACTIVE) - tp%rb(:, i) = tp%rh(:, i) + cb%rb(:) - end do - end associate - - return - end subroutine util_coord_rh2rb_tp - -end submodule s_util_coord \ No newline at end of file diff --git a/src/util/util_copy.f90 b/src/util/util_copy.f90 deleted file mode 100644 index bef861d07..000000000 --- a/src/util/util_copy.f90 +++ /dev/null @@ -1,95 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule(swiftest_classes) s_util_copy - use swiftest -contains - - module subroutine util_copy_particle_info(self, source) - !! author: David A. Minton - !! - !! Copies one set of information object components into another, component-by-component - implicit none - class(swiftest_particle_info), intent(inout) :: self - class(swiftest_particle_info), intent(in) :: source - - call self%set_value(& - name = source%name, & - particle_type = source%particle_type, & - status = source%status, & - origin_type = source%origin_type, & - origin_time = source%origin_time, & - collision_id = source%collision_id, & - origin_rh = source%origin_rh(:), & - origin_vh = source%origin_vh(:), & - discard_time = source%discard_time, & - discard_rh = source%discard_rh(:), & - discard_vh = source%discard_vh(:), & - discard_body_id = source%discard_body_id & - ) - - return - end subroutine util_copy_particle_info - - - module subroutine util_copy_particle_info_arr(source, dest, idx) - !! author: David A. Minton - !! - !! Copies contents from an array of one particle information objects to another. - implicit none - class(swiftest_particle_info), dimension(:), intent(in) :: source !! Source object to copy into - class(swiftest_particle_info), dimension(:), intent(inout) :: dest !! Swiftest body object with particle metadata information object - integer(I4B), dimension(:), intent(in), optional :: idx !! Optional array of indices to draw the source object - ! Internals - integer(I4B) :: i, j, n, nsource, ndest - - if (size(source) == 0) return - - if (present(idx)) then - n = size(idx) - else - n = size(source) - end if - - nsource = size(source) - ndest = size(dest) - - if ((n == 0) .or. (n > ndest) .or. (n > nsource)) then - write(*,*) 'Particle info copy operation failed. n, nsource, ndest: ',n, nsource, ndest - return - end if - - do i = 1, n - if (present(idx)) then - j = idx(i) - else - j = i - end if - call dest(i)%copy(source(j)) - end do - - return - end subroutine util_copy_particle_info_arr - - - module subroutine util_copy_store(self, source) - !! author: David A. Minton - !! - !! Stores a snapshot of the nbody system so that later it can be retrieved for saving to file. - implicit none - class(swiftest_storage_frame), intent(inout) :: self !! Swiftest storage frame object - class(*), intent(in) :: source !! Swiftest n-body system object - - if (allocated(self%item)) deallocate(self%item) - allocate(self%item, source=source) - - return - end subroutine util_copy_store - -end submodule s_util_copy diff --git a/src/util/util_dealloc.f90 b/src/util/util_dealloc.f90 deleted file mode 100644 index 14309d2a6..000000000 --- a/src/util/util_dealloc.f90 +++ /dev/null @@ -1,93 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule (swiftest_classes) s_util_dealloc - use swiftest -contains - - module subroutine util_dealloc_body(self) - !! author: David A. Minton - !! - !! Finalize the swiftest body object - deallocates all allocatables - implicit none - ! Argument - class(swiftest_body), intent(inout) :: self - - if (allocated(self%info)) deallocate(self%info) - if (allocated(self%id)) deallocate(self%id) - if (allocated(self%status)) deallocate(self%status) - if (allocated(self%ldiscard)) deallocate(self%ldiscard) - if (allocated(self%lmask)) deallocate(self%lmask) - if (allocated(self%mu)) deallocate(self%mu) - if (allocated(self%rh)) deallocate(self%rh) - if (allocated(self%vh)) deallocate(self%vh) - if (allocated(self%rb)) deallocate(self%rb) - if (allocated(self%vb)) deallocate(self%vb) - if (allocated(self%ah)) deallocate(self%ah) - if (allocated(self%aobl)) deallocate(self%aobl) - if (allocated(self%agr)) deallocate(self%agr) - if (allocated(self%atide)) deallocate(self%atide) - if (allocated(self%ir3h)) deallocate(self%ir3h) - if (allocated(self%a)) deallocate(self%a) - if (allocated(self%e)) deallocate(self%e) - if (allocated(self%e)) deallocate(self%e) - if (allocated(self%inc)) deallocate(self%inc) - if (allocated(self%capom)) deallocate(self%capom) - if (allocated(self%omega)) deallocate(self%omega) - if (allocated(self%capm)) deallocate(self%capm) - - return - end subroutine util_dealloc_body - - - module subroutine util_dealloc_pl(self) - !! author: David A. Minton - !! - !! Finalize the swiftest massive body object - deallocates all allocatables - implicit none - ! Argument - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - - if (allocated(self%mass)) deallocate(self%mass) - if (allocated(self%Gmass)) deallocate(self%Gmass) - if (allocated(self%rhill)) deallocate(self%rhill) - if (allocated(self%renc)) deallocate(self%renc) - if (allocated(self%radius)) deallocate(self%radius) - if (allocated(self%density)) deallocate(self%density) - if (allocated(self%rot)) deallocate(self%rot) - if (allocated(self%Ip)) deallocate(self%Ip) - if (allocated(self%k2)) deallocate(self%k2) - if (allocated(self%Q)) deallocate(self%Q) - if (allocated(self%tlag)) deallocate(self%tlag) - if (allocated(self%k_plpl)) deallocate(self%k_plpl) - - call util_dealloc_body(self) - - return - end subroutine util_dealloc_pl - - module subroutine util_dealloc_tp(self) - !! author: David A. Minton - !! - !! Finalize the swiftest test particle object - deallocates all allocatables - implicit none - ! Argument - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - - if (allocated(self%isperi)) deallocate(self%isperi) - if (allocated(self%peri)) deallocate(self%peri) - if (allocated(self%atp)) deallocate(self%atp) - if (allocated(self%k_pltp)) deallocate(self%k_pltp) - - call util_dealloc_body(self) - - return - end subroutine util_dealloc_tp - -end submodule s_util_dealloc \ No newline at end of file diff --git a/src/util/util_exit.f90 b/src/util/util_exit.f90 deleted file mode 100644 index a7b77c197..000000000 --- a/src/util/util_exit.f90 +++ /dev/null @@ -1,49 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule (swiftest_classes) s_util_exit - use swiftest -contains - - module subroutine util_exit(code) - !! author: David A. Minton - !! - !! Print termination message and exit program - !! - !! Adapted from David E. Kaufmann's Swifter routine: util_exit.f90 - !! Adapted from Hal Levison's Swift routine util_exit.f - implicit none - ! Arguments - integer(I4B), intent(in) :: code - ! Internals - character(*), parameter :: BAR = '("------------------------------------------------")' - character(*), parameter :: SUCCESS_MSG = '(/, "Normal termination of Swiftest (version ", f3.1, ")")' - character(*), parameter :: FAIL_MSG = '(/, "Terminating Swiftest (version ", f3.1, ") due to error!!")' - character(*), parameter :: USAGE_MSG = '("Usage: swiftest [bs|helio|ra15|rmvs|symba|tu4|whm] [standard|compact|progress|NONE]")' - character(*), parameter :: HELP_MSG = USAGE_MSG - - select case(code) - case(SUCCESS) - write(*, SUCCESS_MSG) VERSION_NUMBER - write(*, BAR) - case(USAGE) - write(*, USAGE_MSG) - case(HELP) - write(*, HELP_MSG) - case default - write(*, FAIL_MSG) VERSION_NUMBER - write(*, BAR) - error stop - end select - - stop - - end subroutine util_exit - -end submodule s_util_exit diff --git a/src/util/util_fill.f90 b/src/util/util_fill.f90 deleted file mode 100644 index 265138238..000000000 --- a/src/util/util_fill.f90 +++ /dev/null @@ -1,256 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule (swiftest_classes) s_util_fill - use swiftest -contains - - module subroutine util_fill_arr_char_string(keeps, inserts, lfill_list) - !! author: David A. Minton - !! - !! Performs a fill operation on a single array of type character strings - !! This is the inverse of a spill operation - implicit none - ! Arguments - character(len=STRMAX), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - character(len=STRMAX), 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 util_fill_arr_char_string - - module subroutine util_fill_arr_DP(keeps, inserts, lfill_list) - !! author: David A. Minton - !! - !! Performs a fill operation on a single array of type DP - !! This is the inverse of a spill operation - implicit none - ! Arguments - real(DP), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - real(DP), 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 util_fill_arr_DP - - module subroutine util_fill_arr_DPvec(keeps, inserts, lfill_list) - !! author: David A. Minton - !! - !! Performs a fill operation on a single array of DP vectors with shape (NDIM, n) - !! This is the inverse of a spill operation - implicit none - ! Arguments - real(DP), dimension(:,:), allocatable, intent(inout) :: keeps !! Array of values to keep - real(DP), 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 - ! Internals - integer(I4B) :: i - - if (.not.allocated(keeps) .or. .not.allocated(inserts)) return - - do i = 1, NDIM - keeps(i,:) = unpack(keeps(i,:), .not.lfill_list(:), keeps(i,:)) - keeps(i,:) = unpack(inserts(i,:), lfill_list(:), keeps(i,:)) - end do - - return - end subroutine util_fill_arr_DPvec - - module subroutine util_fill_arr_I4B(keeps, inserts, lfill_list) - !! author: David A. Minton - !! - !! Performs a fill operation on a single array of type I4B - !! This is the inverse of a spill operation - implicit none - ! Arguments - integer(I4B), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - integer(I4B), 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 util_fill_arr_I4B - - - module subroutine util_fill_arr_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(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - type(swiftest_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 - ! Internals - integer(I4B), dimension(:), allocatable :: insert_idx - integer(I4B) :: i, nkeep, ninsert - - if (.not.allocated(keeps) .or. .not.allocated(inserts)) return - - nkeep = size(keeps) - ninsert = count(lfill_list) - - allocate(insert_idx(ninsert)) - - insert_idx(:) = pack([(i, i = 1, nkeep)], lfill_list) - call util_copy_particle_info_arr(inserts, keeps, insert_idx) - - return - end subroutine util_fill_arr_info - - - module subroutine util_fill_arr_logical(keeps, inserts, lfill_list) - !! author: David A. Minton - !! - !! Performs a fill operation on a single array of logicals - !! This is the inverse of a spill operation - implicit none - ! Arguments - logical, dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - logical, 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 util_fill_arr_logical - - - module subroutine util_fill_body(self, inserts, lfill_list) - !! author: David A. Minton - !! - !! Insert new Swiftest generic particle structure into an old one. - !! This is the inverse of a spill operation. - implicit none - ! Arguments - class(swiftest_body), intent(inout) :: self !! Swiftest generic body object - class(swiftest_body), intent(in) :: inserts !! Inserted object - logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - - ! For each component, pack the discarded bodies into the discard object and do the inverse with the keeps - !> Fill all the common components - associate(keeps => self) - call util_fill(keeps%id, inserts%id, lfill_list) - call util_fill(keeps%info, inserts%info, lfill_list) - call util_fill(keeps%status, inserts%status, lfill_list) - call util_fill(keeps%ldiscard, inserts%ldiscard, lfill_list) - call util_fill(keeps%lmask, inserts%lmask, lfill_list) - call util_fill(keeps%mu, inserts%mu, lfill_list) - call util_fill(keeps%rh, inserts%rh, lfill_list) - call util_fill(keeps%vh, inserts%vh, lfill_list) - call util_fill(keeps%rb, inserts%rb, lfill_list) - call util_fill(keeps%vb, inserts%vb, lfill_list) - call util_fill(keeps%ah, inserts%ah, lfill_list) - call util_fill(keeps%aobl, inserts%aobl, lfill_list) - call util_fill(keeps%agr, inserts%agr, lfill_list) - call util_fill(keeps%atide, inserts%atide, lfill_list) - call util_fill(keeps%a, inserts%a, lfill_list) - call util_fill(keeps%e, inserts%e, lfill_list) - call util_fill(keeps%inc, inserts%inc, lfill_list) - call util_fill(keeps%capom, inserts%capom, lfill_list) - call util_fill(keeps%omega, inserts%omega, lfill_list) - call util_fill(keeps%capm, inserts%capm, lfill_list) - - ! This is the base class, so will be the last to be called in the cascade. - keeps%nbody = size(keeps%id(:)) - end associate - - return - end subroutine util_fill_body - - - module subroutine util_fill_pl(self, inserts, lfill_list) - !! author: David A. Minton - !! - !! Insert new Swiftest massive body structure into an old one. - !! This is the inverse of a spill operation. - implicit none - ! Arguments - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_body), intent(in) :: inserts !! Swiftest body object to be inserted - logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - - associate(keeps => self) - - select type (inserts) ! The standard requires us to select the type of both arguments in order to access all the components - class is (swiftest_pl) - !> Fill components specific to the massive body class - call util_fill(keeps%mass, inserts%mass, lfill_list) - call util_fill(keeps%Gmass, inserts%Gmass, lfill_list) - call util_fill(keeps%rhill, inserts%rhill, lfill_list) - call util_fill(keeps%renc, inserts%renc, lfill_list) - call util_fill(keeps%radius, inserts%radius, lfill_list) - call util_fill(keeps%density, inserts%density, lfill_list) - call util_fill(keeps%k2, inserts%k2, lfill_list) - call util_fill(keeps%Q, inserts%Q, lfill_list) - call util_fill(keeps%tlag, inserts%tlag, lfill_list) - call util_fill(keeps%rbeg, inserts%rbeg, lfill_list) - call util_fill(keeps%vbeg, inserts%vbeg, lfill_list) - call util_fill(keeps%Ip, inserts%Ip, lfill_list) - call util_fill(keeps%rot, inserts%rot, lfill_list) - - if (allocated(keeps%k_plpl)) deallocate(keeps%k_plpl) - - call util_fill_body(keeps, inserts, lfill_list) - class default - write(*,*) 'Error! fill method called for incompatible return type on swiftest_pl' - end select - end associate - - return - end subroutine util_fill_pl - - - module subroutine util_fill_tp(self, inserts, lfill_list) - !! author: David A. Minton - !! - !! Insert new Swiftest test particle structure into an old one. - !! This is the inverse of a fill operation. - implicit none - ! Arguments - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - class(swiftest_body), intent(in) :: inserts !! Swiftest body object to be inserted - logical, dimension(:), intent(in) :: lfill_list !! Logical array of bodies to merge into the keeps - - associate(keeps => self) - select type(inserts) - class is (swiftest_tp) - !> Spill components specific to the test particle class - 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) - - call util_fill_body(keeps, inserts, lfill_list) - class default - write(*,*) 'Error! fill method called for incompatible return type on swiftest_tp' - end select - end associate - - return - end subroutine util_fill_tp - -end submodule s_util_fill \ No newline at end of file diff --git a/src/util/util_final.f90 b/src/util/util_final.f90 deleted file mode 100644 index 4f4a6dd28..000000000 --- a/src/util/util_final.f90 +++ /dev/null @@ -1,62 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule (swiftest_classes) s_util_final - use swiftest -contains - - module subroutine util_final_storage(self) - !! author: David A. Minton - !! - !! Finalizer for the storage data type - implicit none - ! Arguments - type(swiftest_storage(*)) :: self - ! Internals - integer(I4B) :: i - - do i = 1, self%nframes - if (allocated(self%frame(i)%item)) deallocate(self%frame(i)%item) - end do - - return - end subroutine util_final_storage - - module subroutine util_final_storage_frame(self) - !! author: David A. Minton - !! - !! Finalizer for the storage frame data type - implicit none - type(swiftest_storage_frame) :: self - - if (allocated(self%item)) deallocate(self%item) - - return - end subroutine util_final_storage_frame - - - module subroutine util_final_system(self) - !! author: David A. Minton - !! - !! Finalize the swiftest nbody system object - deallocates all allocatables - implicit none - ! Argument - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object - - if (allocated(self%cb)) deallocate(self%cb) - if (allocated(self%pl)) deallocate(self%pl) - if (allocated(self%tp)) deallocate(self%tp) - if (allocated(self%tp_discards)) deallocate(self%tp_discards) - if (allocated(self%pl_discards)) deallocate(self%pl_discards) - - return - end subroutine util_final_system - - -end submodule s_util_final diff --git a/src/util/util_flatten.f90 b/src/util/util_flatten.f90 deleted file mode 100644 index 36fee2489..000000000 --- a/src/util/util_flatten.f90 +++ /dev/null @@ -1,148 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule (swiftest_classes) s_util_index - use swiftest -contains - - pure module subroutine util_flatten_eucl_ij_to_k(n, i, j, k) - !! author: Jacob R. Elliott and David A. Minton - !! - !! Turns i,j indices into k index for use in the Euclidean distance matrix for pl-pl interactions. - !! - !! Reference: - !! - !! Mélodie Angeletti, Jean-Marie Bonny, Jonas Koko. Parallel Euclidean distance matrix computation on big datasets *. - !! 2019. hal-0204751 - implicit none - ! Arguments - integer(I4B), intent(in) :: n !! Number of bodies - integer(I4B), intent(in) :: i !! Index of the ith body - integer(I4B), intent(in) :: j !! Index of the jth body - integer(I8B), intent(out) :: k !! Index of the flattened matrix - ! Internals - integer(I8B) :: i8, j8, n8 - - i8 = int(i, kind=I8B) - j8 = int(j, kind=I8B) - n8 = int(n, kind=I8B) - k = (i8 - 1_I8B) * n8 - i8 * (i8 - 1_I8B) / 2_I8B + (j8 - i8) - - return - end subroutine util_flatten_eucl_ij_to_k - - - pure module subroutine util_flatten_eucl_k_to_ij(n, k, i, j) - !! author: Jacob R. Elliott and David A. Minton - !! - !! Turns k index into i,j indices for use in the Euclidean distance matrix for pl-pl interactions. - !! - !! Reference: - !! - !! Mélodie Angeletti, Jean-Marie Bonny, Jonas Koko. Parallel Euclidean distance matrix computation on big datasets *. - !! 2019. hal-0204751 - implicit none - ! Arguments - integer(I4B), intent(in) :: n !! Number of bodies - integer(I8B), intent(in) :: k !! Index of the flattened matrix - integer(I4B), intent(out) :: i !! Index of the ith body - integer(I4B), intent(out) :: j !! Index of the jth body - ! Internals - integer(I8B) :: kp, p, i8, j8, n8 - - n8 = int(n, kind=I8B) - - kp = n8 * (n8 - 1_I8B) / 2_I8B - k - p = floor((sqrt(1._DP + 8_I8B * kp) - 1_I8B) / 2_I8B) - i8 = n8 - 1_I8B - p - j8 = k - (n8 - 1_I8B) * (n8 - 2_I8B) / 2_I8B + p * (p + 1_I8B) / 2_I8B + 1_I8B - - i = int(i8, kind=I4B) - j = int(j8, kind=I4B) - - return - end subroutine util_flatten_eucl_k_to_ij - - - module subroutine util_flatten_eucl_plpl(self, param) - !! author: Jacob R. Elliott and David A. Minton - !! - !! Turns i,j indices into k index for use in the Euclidean distance matrix for pl-pl interactions for a Swiftest massive body object - !! - !! Reference: - !! - !! Mélodie Angeletti, Jean-Marie Bonny, Jonas Koko. Parallel Euclidean distance matrix computation on big datasets *. - !! 2019. hal-0204751 - implicit none - ! Arguments - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - ! Internals - integer(I4B) :: i, j, err - integer(I8B) :: k, npl - - npl = int(self%nbody, kind=I8B) - associate(nplpl => self%nplpl) - nplpl = npl * (npl - 1_I8B) / 2_I8B ! number of entries in a strict lower triangle, npl x npl - if (param%lflatten_interactions) then - 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), stat=err) - if (err /=0) then ! An error occurred trying to allocate this big array. This probably means it's too big to fit in memory, and so we will force the run back into triangular mode - param%lflatten_interactions = .false. - else - do concurrent (i=1:npl, j=1:npl, j>i) - call util_flatten_eucl_ij_to_k(self%nbody, i, j, k) - self%k_plpl(1, k) = i - self%k_plpl(2, k) = j - end do - end if - end if - end associate - - return - end subroutine util_flatten_eucl_plpl - - - module subroutine util_flatten_eucl_pltp(self, pl, param) - !! author: Jacob R. Elliott and David A. Minton - !! - !! Turns i,j indices into k index for use in the Euclidean distance matrix for pl-tp interactions - !! - !! Reference: - !! - !! Mélodie Angeletti, Jean-Marie Bonny, Jonas Koko. Parallel Euclidean distance matrix computation on big datasets *. - !! 2019. hal-0204751 - implicit none - ! Arguments - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - class(swiftest_pl), intent(in) :: pl !! Swiftest massive body object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - ! Internals - integer(I8B) :: i, j, counter, npl, ntp - - ntp = int(self%nbody, kind=I8B) - npl = int(pl%nbody, kind=I8B) - associate(npltp => self%npltp) - npltp = npl * ntp - if (allocated(self%k_pltp)) deallocate(self%k_pltp) ! Reset the index array if it's been set previously - allocate(self%k_pltp(2, npltp)) - do i = 1_I8B, npl - counter = (i - 1_I8B) * npl + 1_I8B - do j = 1_I8B, ntp - self%k_pltp(1, counter) = i - self%k_pltp(2, counter) = j - counter = counter + 1_I8B - end do - end do - end associate - - return - end subroutine util_flatten_eucl_pltp - -end submodule s_util_index diff --git a/src/util/util_get_energy_momentum.f90 b/src/util/util_get_energy_momentum.f90 deleted file mode 100644 index cc1e64d15..000000000 --- a/src/util/util_get_energy_momentum.f90 +++ /dev/null @@ -1,219 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule (swiftest_classes) s_util_get_energy_momentum - use swiftest -contains - module subroutine util_get_energy_momentum_system(self, param) - !! author: David A. Minton - !! - !! Compute total system angular momentum vector and kinetic, potential and total system energy - !! - !! Adapted from David E. Kaufmann Swifter routine symba_energy_eucl.f90 - !! - !! Adapted from Martin Duncan's Swift routine anal_energy.f - implicit none - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - ! Internals - integer(I4B) :: i - real(DP) :: kecb, kespincb - real(DP), dimension(self%pl%nbody) :: kepl, kespinpl - real(DP), dimension(self%pl%nbody) :: Lplorbitx, Lplorbity, Lplorbitz - real(DP), dimension(self%pl%nbody) :: Lplspinx, Lplspiny, Lplspinz - real(DP), dimension(NDIM) :: Lcborbit, Lcbspin - real(DP) :: hx, hy, hz - - associate(system => self, pl => self%pl, npl => self%pl%nbody, cb => self%cb) - system%Lorbit(:) = 0.0_DP - system%Lspin(:) = 0.0_DP - system%Ltot(:) = 0.0_DP - system%ke_orbit = 0.0_DP - system%ke_spin = 0.0_DP - - kepl(:) = 0.0_DP - Lplorbitx(:) = 0.0_DP - Lplorbity(:) = 0.0_DP - Lplorbitz(:) = 0.0_DP - Lplspinx(:) = 0.0_DP - Lplspiny(:) = 0.0_DP - Lplspinz(:) = 0.0_DP - - pl%lmask(1:npl) = pl%status(1:npl) /= INACTIVE - - system%GMtot = cb%Gmass + sum(pl%Gmass(1:npl), pl%lmask(1:npl)) - kecb = cb%mass * dot_product(cb%vb(:), cb%vb(:)) - Lcborbit(:) = cb%mass * (cb%rb(:) .cross. cb%vb(:)) - - do concurrent (i = 1:npl, pl%lmask(i)) - hx = pl%rb(2,i) * pl%vb(3,i) - pl%rb(3,i) * pl%vb(2,i) - hy = pl%rb(3,i) * pl%vb(1,i) - pl%rb(1,i) * pl%vb(3,i) - hz = pl%rb(1,i) * pl%vb(2,i) - pl%rb(2,i) * pl%vb(1,i) - - ! Angular momentum from orbit - Lplorbitx(i) = pl%mass(i) * hx - Lplorbity(i) = pl%mass(i) * hy - Lplorbitz(i) = pl%mass(i) * hz - - ! Kinetic energy from orbit - kepl(i) = pl%mass(i) * dot_product(pl%vb(:,i), pl%vb(:,i)) - end do - - if (param%lrotation) then - kespincb = cb%mass * cb%Ip(3) * cb%radius**2 * dot_product(cb%rot(:), cb%rot(:)) - - ! For simplicity, we always assume that the rotation pole is the 3rd principal axis - Lcbspin(:) = cb%Ip(3) * cb%mass * cb%radius**2 * cb%rot(:) - - do concurrent (i = 1:npl, pl%lmask(i)) - ! Currently we assume that the rotation pole is the 3rd principal axis - ! Angular momentum from spin - Lplspinx(i) = pl%mass(i) * pl%Ip(3,i) * pl%radius(i)**2 * pl%rot(1,i) - Lplspiny(i) = pl%mass(i) * pl%Ip(3,i) * pl%radius(i)**2 * pl%rot(2,i) - Lplspinz(i) = pl%mass(i) * pl%Ip(3,i) * pl%radius(i)**2 * pl%rot(3,i) - - ! Kinetic energy from spin - kespinpl(i) = pl%mass(i) * pl%Ip(3,i) * pl%radius(i)**2 * dot_product(pl%rot(:,i), pl%rot(:,i)) - end do - else - kespincb = 0.0_DP - kespinpl(:) = 0.0_DP - end if - - if (param%lflatten_interactions) then - call util_get_energy_potential_flat(npl, pl%nplpl, pl%k_plpl, pl%lmask, cb%Gmass, pl%Gmass, pl%mass, pl%rb, system%pe) - else - call util_get_energy_potential_triangular(npl, pl%lmask, cb%Gmass, pl%Gmass, pl%mass, pl%rb, system%pe) - end if - - ! Potential energy from the oblateness term - if (param%loblatecb) then - call system%obl_pot() - system%pe = system%pe + system%oblpot - end if - - system%ke_orbit = 0.5_DP * (kecb + sum(kepl(1:npl), pl%lmask(1:npl))) - if (param%lrotation) system%ke_spin = 0.5_DP * (kespincb + sum(kespinpl(1:npl), pl%lmask(1:npl))) - - system%Lorbit(1) = Lcborbit(1) + sum(Lplorbitx(1:npl), pl%lmask(1:npl)) - system%Lorbit(2) = Lcborbit(2) + sum(Lplorbity(1:npl), pl%lmask(1:npl)) - system%Lorbit(3) = Lcborbit(3) + sum(Lplorbitz(1:npl), pl%lmask(1:npl)) - - if (param%lrotation) then - system%Lspin(1) = Lcbspin(1) + sum(Lplspinx(1:npl), pl%lmask(1:npl)) - system%Lspin(2) = Lcbspin(2) + sum(Lplspiny(1:npl), pl%lmask(1:npl)) - system%Lspin(3) = Lcbspin(3) + sum(Lplspinz(1:npl), pl%lmask(1:npl)) - end if - - system%te = system%ke_orbit + system%ke_spin + system%pe - system%Ltot(:) = system%Lorbit(:) + system%Lspin(:) - end associate - - return - end subroutine util_get_energy_momentum_system - - - subroutine util_get_energy_potential_flat(npl, nplpl, k_plpl, lmask, GMcb, Gmass, mass, rb, pe) - !! author: David A. Minton - !! - !! Compute total system potential energy - implicit none - ! Arguments - integer(I4B), intent(in) :: npl - integer(I8B), intent(in) :: nplpl - integer(I4B), dimension(:,:), intent(in) :: k_plpl - logical, dimension(:), intent(in) :: lmask - real(DP), intent(in) :: GMcb - real(DP), dimension(:), intent(in) :: Gmass - real(DP), dimension(:), intent(in) :: mass - real(DP), dimension(:,:), intent(in) :: rb - real(DP), intent(out) :: pe - ! Internals - integer(I4B) :: i, j - integer(I8B) :: k - real(DP), dimension(npl) :: pecb - real(DP), dimension(nplpl) :: pepl - logical, dimension(nplpl) :: lstatpl - - ! Do the central body potential energy component first - where(.not. lmask(1:npl)) - pecb(1:npl) = 0.0_DP - end where - - do concurrent(i = 1:npl, lmask(i)) - pecb(i) = -GMcb * mass(i) / norm2(rb(:,i)) - end do - - !$omp parallel do default(private) schedule(static)& - !$omp shared(k_plpl, rb, mass, Gmass, pepl, lstatpl, lmask) & - !$omp firstprivate(nplpl) - do k = 1, nplpl - i = k_plpl(1,k) - j = k_plpl(2,k) - lstatpl(k) = (lmask(i) .and. lmask(j)) - if (lstatpl(k)) then - pepl(k) = -(Gmass(i) * mass(j)) / norm2(rb(:, i) - rb(:, j)) - else - pepl(k) = 0.0_DP - end if - end do - !$omp end parallel do - - pe = sum(pepl(:), lstatpl(:)) + sum(pecb(1:npl), lmask(1:npl)) - - return - end subroutine util_get_energy_potential_flat - - - subroutine util_get_energy_potential_triangular(npl, lmask, GMcb, Gmass, mass, rb, pe) - !! author: David A. Minton - !! - !! Compute total system potential energy - implicit none - ! Arguments - integer(I4B), intent(in) :: npl - logical, dimension(:), intent(in) :: lmask - real(DP), intent(in) :: GMcb - real(DP), dimension(:), intent(in) :: Gmass - real(DP), dimension(:), intent(in) :: mass - real(DP), dimension(:,:), intent(in) :: rb - real(DP), intent(out) :: pe - ! Internals - integer(I4B) :: i, j - real(DP), dimension(npl) :: pecb, pepl - - ! Do the central body potential energy component first - where(.not. lmask(1:npl)) - pecb(1:npl) = 0.0_DP - end where - - do concurrent(i = 1:npl, lmask(i)) - pecb(i) = -GMcb * mass(i) / norm2(rb(:,i)) - end do - - pe = 0.0_DP - !$omp parallel do default(private) schedule(static)& - !$omp shared(lmask, Gmass, mass, rb) & - !$omp firstprivate(npl) & - !$omp reduction(+:pe) - do i = 1, npl - if (lmask(i)) then - do concurrent(j = i+1:npl, lmask(i) .and. lmask(j)) - pepl(j) = - (Gmass(i) * mass(j)) / norm2(rb(:, i) - rb(:, j)) - end do - pe = pe + sum(pepl(i+1:npl), lmask(i+1:npl)) - end if - end do - !$omp end parallel do - pe = pe + sum(pecb(1:npl), lmask(1:npl)) - - return - end subroutine util_get_energy_potential_triangular - -end submodule s_util_get_energy_momentum diff --git a/src/util/util_index.f90 b/src/util/util_index.f90 deleted file mode 100644 index e268b3789..000000000 --- a/src/util/util_index.f90 +++ /dev/null @@ -1,160 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule (swiftest_classes) s_util_index_array - use swiftest -contains - - module subroutine util_index_array(ind_arr, n) - !! author: David A. Minton - !! - !! Creates or resizes an index array of size n where ind_arr = [1, 2, ... n]. - !! This subroutine assumes that if ind_arr is already allocated, it is a pre-existing index array of a different size. - implicit none - ! Arguments - integer(I4B), dimension(:), allocatable, intent(inout) :: ind_arr !! Index array. Input is a pre-existing index array where n /= size(ind_arr). Output is a new index array ind_arr = [1, 2, ... n] - integer(I4B), intent(in) :: n !! The new size of the index array - ! Internals - integer(I4B) :: nold, i - integer(I4B), dimension(:), allocatable :: itmp - - if (allocated(ind_arr)) then - nold = size(ind_arr) - if (nold == n) return ! Nothing to do, so go home - else - nold = 0 - end if - - allocate(itmp(n)) - if (n >= nold) then - if (nold > 0) itmp(1:nold) = ind_arr(1:nold) - itmp(nold+1:n) = [(i, i = nold + 1, n)] - call move_alloc(itmp, ind_arr) - else - itmp(1:n) = ind_arr(1:n) - call move_alloc(itmp, ind_arr) - end if - - return - end subroutine util_index_array - - - module subroutine util_get_idvalues_system(self, idvals) - !! author: David A. Minton - !! - !! Returns an array of all id values saved in this snapshot - implicit none - ! Arguments - class(swiftest_nbody_system), intent(in) :: self !! Encounter snapshot object - integer(I4B), dimension(:), allocatable, intent(out) :: idvals !! Array of all id values saved in this snapshot - ! Internals - integer(I4B) :: npl, ntp - - if (allocated(self%pl)) then - npl = self%pl%nbody - else - npl = 0 - end if - if (allocated(self%tp)) then - ntp = self%tp%nbody - else - ntp = 0 - end if - - allocate(idvals(1 + npl+ntp)) - - idvals(1) = self%cb%id - if (npl > 0) idvals(2:npl+1) = self%pl%id(:) - if (ntp > 0) idvals(npl+2:npl+ntp+1) = self%tp%id(:) - - return - - end subroutine util_get_idvalues_system - - - module subroutine util_get_vals_storage(self, idvals, tvals) - !! author: David A. Minton - !! - !! Gets the id values in a storage object, regardless of whether it is encounter of collision - ! Argument - class(swiftest_storage(*)), intent(in) :: self !! Swiftest storage object - integer(I4B), dimension(:), allocatable, intent(out) :: idvals !! Array of all id values in all snapshots - real(DP), dimension(:), allocatable, intent(out) :: tvals !! Array of all time values in all snapshots - ! Internals - integer(I4B) :: i, n, nlo, nhi, ntotal - integer(I4B), dimension(:), allocatable :: itmp - - associate(nsnaps => self%iframe) - - allocate(tvals(nsnaps)) - tvals(:) = 0.0_DP - - ! First pass to get total number of ids - ntotal = 0 - do i = 1, nsnaps - if (allocated(self%frame(i)%item)) then - select type(snapshot => self%frame(i)%item) - class is (swiftest_nbody_system) - tvals(i) = snapshot%t - call snapshot%get_idvals(itmp) - if (allocated(itmp)) then - n = size(itmp) - ntotal = ntotal + n - end if - end select - end if - end do - - allocate(idvals(ntotal)) - nlo = 1 - ! Second pass to store all ids get all of the ids stored - do i = 1, nsnaps - if (allocated(self%frame(i)%item)) then - select type(snapshot => self%frame(i)%item) - class is (swiftest_nbody_system) - tvals(i) = snapshot%t - call snapshot%get_idvals(itmp) - if (allocated(itmp)) then - n = size(itmp) - nhi = nlo + n - 1 - idvals(nlo:nhi) = itmp(1:n) - nlo = nhi + 1 - end if - end select - end if - end do - - end associate - return - end subroutine util_get_vals_storage - - - module subroutine util_index_map_storage(self) - !! author: David A. Minton - !! - !! Maps body id values to storage index values so we don't have to use unlimited dimensions for id - implicit none - ! Arguments - class(swiftest_storage(*)), intent(inout) :: self !! Swiftest storage object - ! Internals - integer(I4B), dimension(:), allocatable :: idvals - real(DP), dimension(:), allocatable :: tvals - - call self%get_index_values(idvals, tvals) - - call util_unique(idvals,self%idvals,self%idmap) - self%nid = size(self%idvals) - - call util_unique(tvals,self%tvals,self%tmap) - self%nt = size(self%tvals) - - return - end subroutine util_index_map_storage - -end submodule s_util_index_array \ No newline at end of file diff --git a/src/util/util_minimize_bfgs.f90 b/src/util/util_minimize_bfgs.f90 deleted file mode 100644 index 970a0ae45..000000000 --- a/src/util/util_minimize_bfgs.f90 +++ /dev/null @@ -1,593 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule (swiftest_classes) s_util_minimize_bfgs - use swiftest -contains - module subroutine util_minimize_bfgs(f, N, x0, eps, maxloop, lerr, x1) - !! author: David A. Minton - !! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !! This function implements the Broyden-Fletcher-Goldfarb-Shanno method to determine the minimum of a function of N variables. - !! It recieves as input: - !! f%eval(x) : lambda function object containing the objective function as the eval metho - !! N : Number of variables of function f - !! x0 : Initial starting value of x - !! eps : Accuracy of 1 - dimensional minimization at each step - !! maxloop : Maximum number of loops to attempt to find a solution - !! The outputs include - !! lerr : Returns .true. if it could not find the minimum - !! Returns - !! x1 : Final minimum (all 0 if none found) - !! 0 = No miniumum found - !! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - use, intrinsic :: ieee_exceptions - implicit none - ! Arguments - integer(I4B), intent(in) :: N - class(lambda_obj), intent(inout) :: f - real(DP), dimension(:), intent(in) :: x0 - real(DP), intent(in) :: eps - integer(I4B), intent(in) :: maxloop - logical, intent(out) :: lerr - ! Result - real(DP), dimension(:), intent(out), allocatable :: x1 - ! Internals - integer(I4B) :: i, j, k, l, conv - real(DP), parameter :: graddelta = 1e-4_DP !! Delta x for gradient calculations - real(DP), dimension(N) :: S !! Direction vectors - real(DP), dimension(N,N) :: H !! Approximated inverse Hessian matrix - real(DP), dimension(N) :: grad1 !! gradient of f - real(DP), dimension(N) :: grad0 !! old value of gradient - real(DP) :: astar !! 1D minimized value - real(DP), dimension(N) :: y, P - real(DP), dimension(N,N) :: PP, PyH, HyP - real(DP), save :: yHy, Py - type(ieee_status_type) :: original_fpe_status - logical, dimension(:), allocatable :: fpe_flag - - call ieee_get_status(original_fpe_status) ! Save the original floating point exception status - call ieee_set_flag(ieee_all, .false.) ! Set all flags to quiet - allocate(fpe_flag(size(ieee_usual))) - - lerr = .false. - allocate(x1, source=x0) - ! Initialize approximate Hessian with the identity matrix (i.e. begin with method of steepest descent) - ! Get initial gradient and initialize arrays for updated values of gradient and x - H(:,:) = reshape([((0._DP, i=1, j-1), 1._DP, (0._DP, i=j+1, N), j=1, N)], [N,N]) - grad0 = gradf(f, N, x0(:), graddelta, lerr) - if (lerr) then - call ieee_set_status(original_fpe_status) - return - end if - grad1(:) = grad0(:) - do i = 1, maxloop - !check for convergence - conv = count(abs(grad1(:)) > eps) - if (conv == 0) exit - S(:) = -matmul(H(:,:), grad1(:)) - astar = minimize1D(f, x1, S, N, graddelta, lerr) - if (lerr) exit - ! Get new x values - P(:) = astar * S(:) - x1(:) = x1(:) + P(:) - ! Calculate new gradient - grad0(:) = grad1(:) - grad1 = gradf(f, N, x1, graddelta, lerr) - y(:) = grad1(:) - grad0(:) - Py = sum(P(:) * y(:)) - ! set up factors for H matrix update - yHy = 0._DP - !$omp do simd schedule(static)& - !$omp firstprivate(N, y, H) & - !$omp reduction(+:yHy) - do k = 1, N - do j = 1, N - yHy = yHy + y(j) * H(j,k) * y(k) - end do - end do - !$omp end do simd - ! prevent divide by zero (convergence) - if (abs(Py) < tiny(Py)) exit - ! set up update - PyH(:,:) = 0._DP - HyP(:,:) = 0._DP - !$omp parallel do default(private) schedule(static)& - !$omp shared(N, PP, P, y, H) & - !$omp reduction(+:PyH, HyP) - do k = 1, N - do j = 1, N - PP(j, k) = P(j) * P(k) - do l = 1, N - PyH(j, k) = PyH(j, k) + P(j) * y(l) * H(l,k) - HyP(j, k) = HyP(j, k) + P(k) * y(l) * H(j,l) - end do - end do - end do - !$omp end parallel do - ! update H matrix - H(:,:) = H(:,:) + ((1._DP - yHy / Py) * PP(:,:) - PyH(:,:) - HyP(:,:)) / Py - ! Normalize to prevent it from blowing up if it takes many iterations to find a solution - H(:,:) = H(:,:) / norm2(H(:,:)) - ! Stop everything if there are any exceptions to allow the routine to fail gracefully - call ieee_get_flag(ieee_usual, fpe_flag) - if (any(fpe_flag)) exit - if (i == maxloop) then - lerr = .true. - end if - end do - call ieee_get_flag(ieee_usual, fpe_flag) - lerr = lerr .or. any(fpe_flag) - call ieee_set_status(original_fpe_status) - - return - - contains - - function gradf(f, N, x1, dx, lerr) result(grad) - !! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !! Purpose: Estimates the gradient of a function using a central difference - !! approximation - !! Inputs: - !! f%eval(x) : lambda function object containing the objective function as the eval metho - !! N : number of variables N - !! x1 : x value array - !! dx : step size to use when calculating derivatives - !! Outputs: - !! lerr : .true. if an error occurred. Otherwise returns .false. - !! Returns - !! grad : N sized array containing estimated gradient of f at x1 - !! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none - ! Arguments - integer(I4B), intent(in) :: N - class(lambda_obj), intent(inout) :: f - real(DP), dimension(:), intent(in) :: x1 - real(DP), intent(in) :: dx - logical, intent(out) :: lerr - ! Result - real(DP), dimension(N) :: grad - ! Internals - integer(I4B) :: i, j - real(DP), dimension(N) :: xp, xm - real(DP) :: fp, fm - logical :: lerrp, lerrm - - do i = 1, N - do j = 1, N - if (j == i) then - xp(j) = x1(j) + dx - xm(j) = x1(j) - dx - else - xp(j) = x1(j) - xm(j) = x1(j) - end if - end do - select type (f) - class is (lambda_obj_err) - fp = f%eval(xp) - lerrp = f%lerr - fm = f%eval(xm) - lerrm = f%lerr - lerr = lerrp .or. lerrm - class is (lambda_obj) - fp = f%eval(xp) - fm = f%eval(xm) - lerr = .false. - end select - grad(i) = (fp - fm) / (2 * dx) - if (lerr) return - end do - return - end function gradf - - - function minimize1D(f, x0, S, N, eps, lerr) result(astar) - !! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !! This program find the minimum of a function of N variables in a single direction - !! S using in sequence: - !! 1. A Bracketing method - !! 2. The golden section method - !! 3. A quadratic polynomial fit - !! Inputs - !! f%eval(x) : lambda function object containing the objective function as the eval metho - !! x0 : Array of size N of initial x values - !! S : Array of size N that determines the direction of minimization - !! N : Number of variables of function f - !! eps : Accuracy of 1 - dimensional minimization at each step - !! Output - !! lerr : .true. if an error occurred. Otherwise returns .false. - !! Returns - !! astar : Final minimum along direction S - !! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none - ! Arguments - integer(I4B), intent(in) :: N - class(lambda_obj), intent(inout) :: f - real(DP), dimension(:), intent(in) :: x0, S - real(DP), intent(in) :: eps - logical, intent(out) :: lerr - ! Result - real(DP) :: astar - ! Internals - integer(I4B) :: num = 0 - real(DP), parameter :: step = 0.7_DP !! Bracketing method step size - real(DP), parameter :: gam = 1.2_DP !! Bracketing method expansion parameter - real(DP), parameter :: greduce = 0.2_DP !! Golden section method reduction factor - real(DP), parameter :: greduce2 = 0.1_DP ! Secondary golden section method reduction factor - real(DP) :: alo, ahi !! High and low values for 1 - D minimization routines - real(DP), parameter :: a0 = epsilon(1.0_DP) !! Initial guess of alpha - - alo = a0 - call bracket(f, x0, S, N, gam, step, alo, ahi, lerr) - if (lerr) then - !write(*,*) "BFGS bracketing step failed!" - !write(*,*) "alo: ",alo, "ahi: ", ahi - return - end if - if (abs(alo - ahi) < eps) then - astar = alo - lerr = .false. - return - end if - call golden(f, x0, S, N, greduce, alo, ahi, lerr) - if (lerr) then - !write(*,*) "BFGS golden section step failed!" - return - end if - if (abs(alo - ahi) < eps) then - astar = alo - lerr = .false. - return - end if - call quadfit(f, x0, S, N, eps, alo, ahi, lerr) - if (lerr) then - !write(*,*) "BFGS quadfit failed!" - return - end if - if (abs(alo - ahi) < eps) then - astar = alo - lerr = .false. - return - end if - ! Quadratic fit method won't converge, so finish off with another golden section - call golden(f, x0, S, N, greduce2, alo, ahi, lerr) - if (.not. lerr) astar = (alo + ahi) / 2.0_DP - return - end function minimize1D - - - function n2one(f, x0, S, N, a, lerr) result(fnew) - implicit none - ! Arguments - integer(I4B), intent(in) :: N - class(lambda_obj), intent(inout) :: f - real(DP), dimension(:), intent(in) :: x0, S - real(DP), intent(in) :: a - logical, intent(out) :: lerr - - ! Return - real(DP) :: fnew - ! Internals - real(DP), dimension(N) :: xnew - integer(I4B) :: i - - xnew(:) = x0(:) + a * S(:) - fnew = f%eval(xnew(:)) - select type(f) - class is (lambda_obj_err) - lerr = f%lerr - class is (lambda_obj) - lerr = .false. - end select - return - end function n2one - - ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - subroutine bracket(f, x0, S, N, gam, step, lo, hi, lerr) - ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !! This subroutine brackets the minimum. It recieves as input: - !! f%eval(x) : lambda function object containing the objective function as the eval metho - !! x0 : Array of size N of initial x values - !! S : Array of size N that determines the direction of minimization - !! gam : expansion parameter - !! step : step size - !! lo : initial guess of lo bracket value - !! The outputs include - !! lo : lo bracket - !! hi : hi bracket - !! lerr : .true. if an error occurred. Otherwise returns .false. - !! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none - ! Arguments - integer(I4B), intent(in) :: N - class(lambda_obj), intent(inout) :: f - real(DP), dimension(:), intent(in) :: x0, S - real(DP), intent(in) :: gam, step - real(DP), intent(inout) :: lo - real(DP), intent(out) :: hi - logical, intent(out) :: lerr - ! Internals - real(DP) :: a0, a1, a2, atmp, da - real(DP) :: f0, f1, f2 - integer(I4B) :: i, j - integer(I4B), parameter :: MAXLOOP = 100 ! maximum number of loops before method is determined to have failed - real(DP), parameter :: eps = epsilon(lo) ! small number precision to test floating point equality - - ! set up initial bracket points - a0 = lo - da = step - a1 = a0 + da - a2 = a0 + 2 * da - f0 = n2one(f, x0, S, N, a0, lerr) - if (lerr) return - f1 = n2one(f, x0, S, N, a1, lerr) - if (lerr) return - f2 = n2one(f, x0, S, N, a2, lerr) - if (lerr) return - ! loop over bracket method until either min is bracketed method fails - do i = 1, MAXLOOP - if ((f0 > f1) .and. (f1 < f2)) then ! Minimum was found - lo = a0 - hi = a2 - return - else if ((f0 >= f1) .and. (f1 > f2)) then ! Function appears to decrease - da = da * gam - atmp = a2 + da - a0 = a1 - a1 = a2 - a2 = atmp - f0 = f1 - f1 = f2 - f2 = n2one(f, x0, S, N, a2, lerr) - else if ((f0 < f1) .and. (f1 <= f2)) then ! Function appears to increase - da = da * gam - atmp = a0 - da - a2 = a1 - a1 = a0 - a0 = atmp - f2 = f1 - f0 = n2one(f, x0, S, N, a0, lerr) - else if ((f0 < f1) .and. (f1 > f2)) then ! We are at a peak. Pick the direction that descends the fastest - da = da * gam - if (f2 > f0) then ! LHS is lower than RHS - atmp = a2 + da - a0 = a1 - a1 = a2 - a2 = atmp - f0 = f1 - f1 = f2 - f2 = n2one(f, x0, S, N, a2, lerr) - else ! RHS is lower than LHS - atmp = a0 - da - a2 = a1 - a1 = a0 - a0 = atmp - f2 = f1 - f1 = f2 - f0 = n2one(f, x0, S, N, a0, lerr) - end if - else if ((f0 > f1) .and. (abs(f2 - f1) <= eps)) then ! Decrasging but RHS equal - da = da * gam - atmp = a2 + da - a2 = atmp - f2 = n2one(f, x0, S, N, a2, lerr) - else if ((abs(f0 - f1) < eps) .and. (f1 < f2)) then ! Increasing but LHS equal - da = da * gam - atmp = a0 - da - a0 = atmp - f0 = n2one(f, x0, S, N, a0, lerr) - else ! all values equal. Expand in either direction and try again - a0 = a0 - da - a2 = a2 + da - f0 = n2one(f, x0, S, N, a0, lerr) - if (lerr) exit ! An error occurred while evaluating the function - f2 = n2one(f, x0, S, N, a2, lerr) - end if - if (lerr) exit ! An error occurred while evaluating the function - end do - lerr = .true. - return ! no minimum found - end subroutine bracket - - ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - subroutine golden(f, x0, S, N, eps, lo, hi, lerr) - ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !! This function uses the golden section method to reduce the starting interval lo, hi by some amount sigma. - !! It recieves as input: - !! f%eval(x) : lambda function object containing the objective function as the eval metho - !! x0 : Array of size N of initial x values - !! S : Array of size N that determines the direction of minimization - !! gam : expansion parameter - !! eps : reduction interval in range (0 < sigma < 1) such that: - !! hi(new) - lo(new) = eps * (hi(old) - lo(old)) - !! lo : initial guess of lo bracket value - !! The outputs include - !! lo : lo bracket - !! hi : hi bracket - !! lerr : .true. if an error occurred. Otherwise returns .false. - !! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none - ! Arguments - integer(I4B), intent(in) :: N - class(lambda_obj), intent(inout) :: f - real(DP), dimension(:), intent(in) :: x0, S - real(DP), intent(in) :: eps - real(DP), intent(inout) :: lo - real(DP), intent(out) :: hi - logical, intent(out) :: lerr - ! Internals - real(DP), parameter :: tau = 0.5_DP * (sqrt(5.0_DP) - 1.0_DP) ! Golden section constant - integer(I4B), parameter :: MAXLOOP = 40 ! maximum number of loops before method is determined to have failed (unlikely, but could occur if no minimum exists between lo and hi) - real(DP) :: i0 ! Initial interval value - real(DP) :: a1, a2 - real(DP) :: f1, f2 - integer(I4B) :: i, j - - i0 = hi - lo - a1 = hi - tau * i0 - a2 = lo + tau * i0 - f1 = n2one(f, x0, S, N, a1, lerr) - if (lerr) return - f2 = n2one(f, x0, S, N, a2, lerr) - if (lerr) return - do i = 1, MAXLOOP - if (abs((hi - lo) / i0) <= eps) return ! interval reduced to input amount - if (f2 > f1) then - hi = a2 - a2 = a1 - f2 = f1 - a1 = hi - tau * (hi - lo) - f1 = n2one(f, x0, S, N, a1, lerr) - else - lo = a1 - a1 = a2 - f2 = f1 - a2 = hi - (1.0_DP - tau) * (hi - lo) - f2 = n2one(f, x0, S, N, a2, lerr) - end if - if (lerr) exit - end do - lerr = .true. - return ! search took too many iterations - no minimum found - end subroutine golden - - ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - subroutine quadfit(f, x0, S, N, eps, lo, hi, lerr) - ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - !! This function uses a quadratic polynomial fit to locate the minimum of a function - !! to some accuracy eps. It recieves as input: - !! f%eval(x) : lambda function object containing the objective function as the eval metho - !! lo : low bracket value - !! hi : high bracket value - !! eps : desired accuracy of final minimum location - !! The outputs include - !! lo : final minimum location - !! hi : final minimum location - !! Notes: Uses the ieee_exceptions intrinsic module to allow for graceful failure due to floating point exceptions, which won't terminate the run. - !! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - implicit none - ! Arguments - integer(I4B), intent(in) :: N - class(lambda_obj), intent(inout) :: f - real(DP), dimension(:), intent(in) :: x0, S - real(DP), intent(in) :: eps - real(DP), intent(inout) :: lo - real(DP), intent(out) :: hi - logical, intent(out) :: lerr - ! Internals - integer(I4B), parameter :: MAXLOOP = 20 ! maximum number of loops before method is determined to have failed. - real(DP) :: a1, a2, a3, astar ! three points for the polynomial fit and polynomial minimum - real(DP) :: f1, f2, f3, fstar ! three function values for the polynomial and polynomial minimum - real(DP), dimension(3) :: row_1, row_2, row_3, rhs, soln ! matrix for 3 equation solver (gaussian elimination) - real(DP), dimension(3,3) :: lhs - real(DP) :: d1, d2, d3, aold, denom, errval - integer(I4B) :: i - - lerr = .false. - ! Get initial a1, a2, a3 values - a1 = lo - a2 = lo + 0.5_DP * (hi - lo) - a3 = hi - aold = a1 - astar = a2 - f1 = n2one(f, x0, S, N, a1, lerr) - if (lerr) return - f2 = n2one(f, x0, S, N, a2, lerr) - if (lerr) return - f3 = n2one(f, x0, S, N, a3, lerr) - if (lerr) return - do i = 1, MAXLOOP - ! check to see if convergence is reached and exit - errval = abs((astar - aold) / astar) - call ieee_get_flag(ieee_usual, fpe_flag) - if (any(fpe_flag)) then - !write(*,*) 'quadfit fpe' - !write(*,*) 'aold : ',aold - !write(*,*) 'astar: ',astar - lerr = .true. - exit - end if - if (errval < eps) then - lo = astar - hi = astar - exit - end if - ! Set up system for gaussian elimination equation solver - row_1 = [1.0_DP, a1, a1**2] - row_2 = [1.0_DP, a2, a2**2] - row_3 = [1.0_DP, a3, a3**2] - rhs = [f1, f2, f3] - lhs(1, :) = row_1 - lhs(2, :) = row_2 - lhs(3, :) = row_3 - ! Solve system of equations - soln(:) = util_solve_linear_system(lhs, rhs, 3, lerr) - call ieee_set_flag(ieee_all, .false.) ! Set all flags back to quiet - call ieee_set_halting_mode(ieee_divide_by_zero, .false.) - if (lerr) then - !write(*,*) 'quadfit fpe:' - !write(*,*) 'util_solve_linear_system failed' - exit - end if - aold = astar - if (soln(2) == soln(3)) then ! Handles the case where they are both 0. 0/0 is an unhandled exception - astar = -0.5_DP - else - astar = -soln(2) / (2 * soln(3)) - end if - call ieee_get_flag(ieee_usual, fpe_flag) - if (any(fpe_flag)) then - !write(*,*) 'quadfit fpe' - !write(*,*) 'soln(2:3): ',soln(2:3) - !write(*,*) 'a1, a2, a3' - !write(*,*) a1, a2, a3 - !write(*,*) 'f1, f2, f3' - !write(*,*) f1, f2, f3 - lerr = .true. - exit - end if - fstar = n2one(f, x0, S, N, astar, lerr) - if (lerr) exit - ! keep the three closest a values to astar and discard the fourth - d1 = abs(a1 - astar) - d2 = abs(a2 - astar) - d3 = abs(a3 - astar) - - if (d1 > d2) then - if (d1 > d3) then - f1 = fstar - a1 = astar - else if (d3 > d2) then - f3 = fstar - a3 = astar - end if - else - if (d2 > d3) then - f2 = fstar - a2 = astar - else if (d3 > d1) then - f3 = fstar - a3 = astar - end if - end if - end do - if (lerr) return - lo = a1 - hi = a3 - return - end subroutine quadfit - - end subroutine util_minimize_bfgs -end submodule s_util_minimize_bfgs \ No newline at end of file diff --git a/src/util/util_peri.f90 b/src/util/util_peri.f90 deleted file mode 100644 index 76252828e..000000000 --- a/src/util/util_peri.f90 +++ /dev/null @@ -1,75 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule (swiftest_classes) s_util_peri - use swiftest -contains - - module subroutine util_peri_tp(self, system, param) - !! author: David A. Minton - !! - !! Determine system pericenter passages for test particles - !! Note: If the coordinate system used is barycentric, then this routine assumes that the barycentric coordinates in the - !! test particle structures are up-to-date and are not recomputed - !! - !! Adapted from David E. Kaufmann's Swifter routine: util_peri.f90 - !! Adapted from Hal Levison's Swift routine util_peri.f - implicit none - ! Arguments - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object - class(swiftest_parameters), intent(in) :: param !! Current run configuration parameters - ! Internals - integer(I4B) :: i - real(DP) :: e - real(DP), dimension(:), allocatable :: vdotr - - associate(tp => self, ntp => self%nbody) - allocate(vdotr(ntp)) - if (param%qmin_coord == "HELIO") then - do i = 1, ntp - vdotr(i) = dot_product(tp%rh(:, i), tp%vh(:, i)) - if (tp%isperi(i) == -1) then - if (vdotr(i) >= 0.0_DP) then - tp%isperi(i) = 0 - call orbel_xv2aeq(tp%mu(i), tp%rh(1,i), tp%rh(2,i), tp%rh(3,i), tp%vh(1,i), tp%vh(2,i), tp%vh(3,i), & - tp%atp(i), e, tp%peri(i)) - end if - else - if (vdotr(i) > 0.0_DP) then - tp%isperi(i) = 1 - else - tp%isperi(i) = -1 - end if - end if - end do - else - do i = 1, ntp - vdotr(i) = dot_product(tp%rb(:, i), tp%vb(:, i)) - if (tp%isperi(i) == -1) then - if (vdotr(i) >= 0.0_DP) then - tp%isperi(i) = 0 - call orbel_xv2aeq(system%Gmtot, tp%rb(1,i), tp%rb(2,i), tp%rb(3,i), tp%vb(1,i), tp%vb(2,i), tp%vb(3,i), & - tp%atp(i), e, tp%peri(i)) - end if - else - if (vdotr(i) > 0.0_DP) then - tp%isperi(i) = 1 - else - tp%isperi(i) = -1 - end if - end if - end do - end if - end associate - - return - end subroutine util_peri_tp - -end submodule s_util_peri diff --git a/src/util/util_rescale.f90 b/src/util/util_rescale.f90 deleted file mode 100644 index 372edd3fb..000000000 --- a/src/util/util_rescale.f90 +++ /dev/null @@ -1,63 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule (swiftest_classes) s_util_rescale - use swiftest -contains - module subroutine util_rescale_system(self, param, mscale, dscale, tscale) - !! author: David A. Minton - !! - !! Rescales an nbody system to a new set of units. Inputs are the multipliers on the mass (mscale), distance (dscale), and time units (tscale). - !! Rescales all united quantities in the system, as well as the mass conversion factors, gravitational constant, and Einstein's constant in the parameter object. - implicit none - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters. Returns with new values of the scale vactors and GU - real(DP), intent(in) :: mscale, dscale, tscale !! Scale factors for mass, distance, and time units, respectively. - ! Internals - real(DP) :: vscale - - param%MU2KG = param%MU2KG * mscale - param%DU2M = param%DU2M * dscale - param%TU2S = param%TU2S * tscale - - ! Calculate the G for the system units - param%GU = GC / (param%DU2M**3 / (param%MU2KG * param%TU2S**2)) - - if (param%lgr) then - ! Calculate the inverse speed of light in the system units - param%inv_c2 = einsteinC * param%TU2S / param%DU2M - param%inv_c2 = (param%inv_c2)**(-2) - end if - - vscale = dscale / tscale - - associate(cb => self%cb, pl => self%pl, npl => self%pl%nbody, tp => self%tp, ntp => self%tp%nbody) - - cb%mass = cb%mass / mscale - cb%Gmass = param%GU * cb%mass - cb%radius = cb%radius / dscale - cb%rb(:) = cb%rb(:) / dscale - cb%vb(:) = cb%vb(:) / vscale - cb%rot(:) = cb%rot(:) * tscale - pl%mass(1:npl) = pl%mass(1:npl) / mscale - pl%Gmass(1:npl) = param%GU * pl%mass(1:npl) - pl%radius(1:npl) = pl%radius(1:npl) / dscale - pl%rh(:,1:npl) = pl%rh(:,1:npl) / dscale - pl%vh(:,1:npl) = pl%vh(:,1:npl) / vscale - pl%rb(:,1:npl) = pl%rb(:,1:npl) / dscale - pl%vb(:,1:npl) = pl%vb(:,1:npl) / vscale - pl%rot(:,1:npl) = pl%rot(:,1:npl) * tscale - - end associate - - - return - end subroutine util_rescale_system - -end submodule s_util_rescale \ No newline at end of file diff --git a/src/util/util_reset.f90 b/src/util/util_reset.f90 deleted file mode 100644 index 9b37f7d15..000000000 --- a/src/util/util_reset.f90 +++ /dev/null @@ -1,37 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule (swiftest_classes) s_util_reset - use swiftest -contains - - module subroutine util_reset_storage(self) - !! author: David A. Minton - !! - !! Resets a storage object by deallocating all items and resetting the frame counter to 0 - implicit none - ! Arguments - class(swiftest_storage(*)), intent(inout) :: self !! Swiftest storage object - ! Internals - integer(I4B) :: i - - do i = 1, self%nframes - if (allocated(self%frame(i)%item)) deallocate(self%frame(i)%item) - end do - - if (allocated(self%idmap)) deallocate(self%idmap) - if (allocated(self%tmap)) deallocate(self%tmap) - self%nid = 0 - self%nt = 0 - self%iframe = 0 - - return - end subroutine util_reset_storage - -end submodule s_util_reset \ No newline at end of file diff --git a/src/util/util_resize.f90 b/src/util/util_resize.f90 deleted file mode 100644 index 4963fd689..000000000 --- a/src/util/util_resize.f90 +++ /dev/null @@ -1,372 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule (swiftest_classes) s_util_resize - use swiftest -contains - - module subroutine util_resize_arr_char_string(arr, nnew) - !! author: David A. Minton - !! - !! Resizes an array component of type character string. nnew = 0 will deallocate. - implicit none - ! Arguments - character(len=STRMAX), dimension(:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size - ! Internals - character(len=STRMAX), dimension(:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated - integer(I4B) :: nold !! Old size - - if (nnew < 0) return - - if (nnew == 0) then - if (allocated(arr)) deallocate(arr) - return - end if - - if (allocated(arr)) then - nold = size(arr) - else - nold = 0 - end if - - if (nnew == nold) return - - allocate(tmp(nnew)) - if (nold > 0) then - if (nnew > nold) then - tmp(1:nold) = arr(1:nold) - tmp(nold+1:nnew) = "" - else - tmp(1:nnew) = arr(1:nnew) - end if - else - tmp(1:nnew) = "" - end if - call move_alloc(tmp, arr) - - return - end subroutine util_resize_arr_char_string - - - module subroutine util_resize_arr_DP(arr, nnew) - !! author: David A. Minton - !! - !! Resizes an array component of double precision type. Passing nnew = 0 will deallocate. - implicit none - ! Arguments - real(DP), dimension(:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size - ! Internals - real(DP), dimension(:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated - integer(I4B) :: nold !! Old size - real(DP), parameter :: init_val = 0.0_DP - - if (nnew < 0) return - - if (nnew == 0) then - if (allocated(arr)) deallocate(arr) - return - end if - - if (allocated(arr)) then - nold = size(arr) - else - nold = 0 - end if - - if (nnew == nold) return - - allocate(tmp(nnew)) - if (nold > 0) then - if (nnew > nold) then - tmp(1:nold) = arr(1:nold) - tmp(nold+1:nnew) = init_val - else - tmp(1:nnew) = arr(1:nnew) - end if - else - tmp(1:nnew) = init_val - end if - call move_alloc(tmp, arr) - - return - end subroutine util_resize_arr_DP - - - module subroutine util_resize_arr_DPvec(arr, nnew) - !! author: David A. Minton - !! - !! Resizes an array component of double precision vectors of size (NDIM, n). Passing nnew = 0 will deallocate. - implicit none - ! Arguments - real(DP), dimension(:,:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size - ! Internals - real(DP), dimension(:,:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated - integer(I4B) :: nold !! Old size - real(DP), dimension(NDIM), parameter :: init_val = 0.0_DP - integer(I4B) :: i - - if (nnew < 0) return - - if (nnew == 0) then - if (allocated(arr)) deallocate(arr) - return - end if - - if (allocated(arr)) then - nold = size(arr, dim=2) - else - nold = 0 - end if - - if (nnew == nold) return - - allocate(tmp(NDIM, nnew)) - if (nold > 0) then - if (nnew > nold) then - tmp(:,1:nold) = arr(:,1:nold) - do i = nold+1, nnew - tmp(:,i) = init_val(:) - end do - else - tmp(:,1:nnew) = arr(:,1:nnew) - end if - else - do i = 1, nnew - tmp(:, i) = init_val(:) - end do - end if - call move_alloc(tmp, arr) - - return - - return - end subroutine util_resize_arr_DPvec - - - module subroutine util_resize_arr_I4B(arr, nnew) - !! author: David A. Minton - !! - !! Resizes an array component of integer type. Passing nnew = 0 will deallocate. - implicit none - ! Arguments - integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size - ! Internals - integer(I4B), dimension(:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated - integer(I4B) :: nold !! Old size - integer(I4B), parameter :: init_val = -1 - - if (nnew < 0) return - - if (nnew == 0) then - if (allocated(arr)) deallocate(arr) - return - end if - - if (allocated(arr)) then - nold = size(arr) - else - nold = 0 - end if - - if (nnew == nold) return - - allocate(tmp(nnew)) - if (nold > 0) then - if (nnew > nold) then - tmp(1:nold) = arr(1:nold) - tmp(nold+1:nnew) = init_val - else - tmp(1:nnew) = arr(1:nnew) - end if - else - tmp(1:nnew) = init_val - end if - call move_alloc(tmp, arr) - - return - end subroutine util_resize_arr_I4B - - - module subroutine util_resize_arr_info(arr, nnew) - !! author: David A. Minton - !! - !! Resizes an array component of type character string. Array will only be resized if has previously been allocated. Passing nnew = 0 will deallocate. - implicit none - ! Arguments - type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size - ! Internals - type(swiftest_particle_info), dimension(:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated - integer(I4B) :: nold !! Old size - - if (nnew < 0) return - - if (nnew == 0) then - if (allocated(arr)) deallocate(arr) - return - end if - - if (allocated(arr)) then - nold = size(arr) - else - nold = 0 - end if - - if (nnew == nold) return - - allocate(tmp(nnew)) - if (nnew > nold) then - call util_copy_particle_info_arr(arr(1:nold), tmp(1:nold)) - else - call util_copy_particle_info_arr(arr(1:nnew), tmp(1:nnew)) - end if - - call move_alloc(tmp, arr) - - return - end subroutine util_resize_arr_info - - - module subroutine util_resize_arr_logical(arr, nnew) - !! author: David A. Minton - !! - !! Resizes an array component of logical type. Passing nnew = 0 will deallocate. - implicit none - ! Arguments - logical, dimension(:), allocatable, intent(inout) :: arr !! Array to resize - integer(I4B), intent(in) :: nnew !! New size - ! Internals - logical, dimension(:), allocatable :: tmp !! Temporary storage array in case the input array is already allocated - integer(I4B) :: nold !! Old size - logical, parameter :: init_val = .false. - - if (nnew < 0) return - - if (nnew == 0) then - if (allocated(arr)) deallocate(arr) - return - end if - - if (allocated(arr)) then - nold = size(arr) - else - nold = 0 - end if - - if (nnew == nold) return - - allocate(tmp(nnew)) - if (nold > 0) then - if (nnew > nold) then - tmp(1:nold) = arr(1:nold) - tmp(nold+1:nnew) = init_val - else - tmp(1:nnew) = arr(1:nnew) - end if - else - tmp(1:nnew) = init_val - end if - call move_alloc(tmp, arr) - - return - end subroutine util_resize_arr_logical - - - module subroutine util_resize_body(self, nnew) - !! author: David A. Minton - !! - !! Checks the current size of a Swiftest body against the requested size and resizes it if it is too small. - implicit none - ! Arguments - class(swiftest_body), intent(inout) :: self !! Swiftest body object - integer(I4B), intent(in) :: nnew !! New size neded - - call util_resize(self%info, nnew) - call util_resize(self%id, nnew) - call util_resize(self%status, nnew) - call util_resize(self%ldiscard, nnew) - call util_resize(self%lmask, nnew) - call util_resize(self%mu, nnew) - call util_resize(self%rh, nnew) - call util_resize(self%vh, nnew) - call util_resize(self%rb, nnew) - call util_resize(self%vb, nnew) - call util_resize(self%ah, nnew) - call util_resize(self%aobl, nnew) - call util_resize(self%atide, nnew) - call util_resize(self%agr, nnew) - call util_resize(self%ir3h, nnew) - call util_resize(self%a, nnew) - call util_resize(self%e, nnew) - call util_resize(self%inc, nnew) - call util_resize(self%capom, nnew) - call util_resize(self%omega, nnew) - call util_resize(self%capm, nnew) - self%nbody = count(self%status(1:nnew) /= INACTIVE) - - return - end subroutine util_resize_body - - - module subroutine util_resize_pl(self, nnew) - !! author: David A. Minton - !! - !! Checks the current size of a Swiftest massive body against the requested size and resizes it if it is too small. - implicit none - ! Arguments - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - integer(I4B), intent(in) :: nnew !! New size neded - - call util_resize_body(self, nnew) - - call util_resize(self%mass, nnew) - call util_resize(self%Gmass, nnew) - call util_resize(self%rhill, nnew) - call util_resize(self%renc, nnew) - call util_resize(self%radius, nnew) - call util_resize(self%rbeg, nnew) - call util_resize(self%xend, nnew) - call util_resize(self%vbeg, nnew) - call util_resize(self%density, nnew) - call util_resize(self%Ip, nnew) - call util_resize(self%rot, nnew) - call util_resize(self%k2, nnew) - call util_resize(self%Q, nnew) - call util_resize(self%tlag, nnew) - - if (allocated(self%k_plpl)) deallocate(self%k_plpl) - - return - end subroutine util_resize_pl - - - module subroutine util_resize_tp(self, nnew) - !! author: David A. Minton - !! - !! Checks the current size of a Swiftest test particle against the requested size and resizes it if it is too small. - implicit none - ! Arguments - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - integer(I4B), intent(in) :: nnew !! New size neded - - call util_resize_body(self, nnew) - - call util_resize(self%isperi, nnew) - call util_resize(self%peri, nnew) - call util_resize(self%atp, nnew) - - return - end subroutine util_resize_tp - - -end submodule s_util_resize \ No newline at end of file diff --git a/src/util/util_set.f90 b/src/util/util_set.f90 deleted file mode 100644 index 3e7719bff..000000000 --- a/src/util/util_set.f90 +++ /dev/null @@ -1,251 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule(swiftest_classes) s_util_set - !! author: David A. Minton - !! This submodule contains a collection of setter method implementations - use swiftest -contains - - module subroutine util_set_beg_end_pl(self, rbeg, xend, vbeg) - !! author: David A. Minton - !! - !! Sets one or more of the values of rbeg, xend, and vbeg - implicit none - ! Arguments - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - real(DP), dimension(:,:), intent(in), optional :: rbeg, xend, vbeg - - if (present(rbeg)) then - if (allocated(self%rbeg)) deallocate(self%rbeg) - allocate(self%rbeg, source=rbeg) - end if - if (present(xend)) then - if (allocated(self%xend)) deallocate(self%xend) - allocate(self%xend, source=xend) - end if - if (present(vbeg)) then - if (allocated(self%vbeg)) deallocate(self%vbeg) - allocate(self%vbeg, source=vbeg) - end if - - return - end subroutine util_set_beg_end_pl - - - module subroutine util_set_ir3h(self) - !! author: David A. Minton - !! - !! Sets the inverse heliocentric radius term (1/rh**3) for all bodies in a structure - implicit none - ! Arguments - class(swiftest_body), intent(inout) :: self !! Swiftest generic body object - ! Internals - integer(I4B) :: i - real(DP) :: r2, irh - - if (self%nbody > 0) then - - do i = 1, self%nbody - r2 = dot_product(self%rh(:, i), self%rh(:, i)) - irh = 1.0_DP / sqrt(r2) - self%ir3h(i) = irh / r2 - end do - end if - - return - end subroutine util_set_ir3h - - - module subroutine util_set_msys(self) - !! author: David A. Minton - !! - !! Sets the value of msys and the vector mass quantities based on the total mass of the system - implicit none - ! Arguments - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nobdy system object - - self%Gmtot = self%cb%Gmass + sum(self%pl%Gmass(1:self%pl%nbody), self%pl%status(1:self%pl%nbody) /= INACTIVE) - - return - end subroutine util_set_msys - - - module subroutine util_set_mu_pl(self, cb) - !! author: David A. Minton - !! - !! Computes G * (M + m) for each massive body - implicit none - ! Arguments - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object - - if (self%nbody > 0) self%mu(1:self%nbody) = cb%Gmass + self%Gmass(1:self%nbody) - - return - end subroutine util_set_mu_pl - - - module subroutine util_set_mu_tp(self, cb) - !! author: David A. Minton - !! - !! Converts certain scalar values to arrays so that they can be used in elemental functions - implicit none - ! Arguments - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object - - if (self%nbody == 0) return - self%mu(1:self%nbody) = cb%Gmass - - return - end subroutine util_set_mu_tp - - module subroutine util_set_particle_info(self, name, particle_type, status, origin_type, origin_time, collision_id, origin_rh,& - origin_vh, discard_time, discard_rh, discard_vh, discard_body_id) - !! author: David A. Minton - !! - !! Sets one or more values of the particle information metadata object - implicit none - ! Arguments - class(swiftest_particle_info), intent(inout) :: self - character(len=*), intent(in), optional :: name !! Non-unique name - character(len=*), intent(in), optional :: particle_type !! String containing a description of the particle type (e.g. Central Body, Massive Body, Test Particle) - character(len=*), intent(in), optional :: status !! Particle status description: ACTIVE, MERGED, FRAGMENTED, etc. - character(len=*), intent(in), optional :: origin_type !! String containing a description of the origin of the particle (e.g. Initial Conditions, Supercatastrophic, Disruption, etc.) - real(DP), intent(in), optional :: origin_time !! The time of the particle's formation - integer(I4B), intent(in), optional :: collision_id !! The ID fo the collision that formed the particle - real(DP), dimension(:), intent(in), optional :: origin_rh !! The heliocentric distance vector at the time of the particle's formation - real(DP), dimension(:), intent(in), optional :: origin_vh !! The heliocentric velocity vector at the time of the particle's formation - real(DP), intent(in), optional :: discard_time !! The time of the particle's discard - real(DP), dimension(:), intent(in), optional :: discard_rh !! The heliocentric distance vector at the time of the particle's discard - real(DP), dimension(:), intent(in), optional :: discard_vh !! The heliocentric velocity vector at the time of the particle's discard - integer(I4B), intent(in), optional :: discard_body_id !! The id of the other body involved in the discard (0 if no other body involved) - ! Internals - character(len=NAMELEN) :: lenstr - character(len=:), allocatable :: fmtlabel - - write(lenstr, *) NAMELEN - fmtlabel = "(A" // trim(adjustl(lenstr)) // ")" - - if (present(name)) then - write(self%name, fmtlabel) trim(adjustl(name)) - end if - if (present(particle_type)) then - write(self%particle_type, fmtlabel) trim(adjustl(particle_type)) - end if - if (present(status)) then - write(self%status, fmtlabel) trim(adjustl(status)) - end if - if (present(origin_type)) then - write(self%origin_type, fmtlabel) trim(adjustl(origin_type)) - end if - if (present(origin_time)) then - self%origin_time = origin_time - end if - if (present(collision_id)) then - self%collision_id = collision_id - end if - if (present(origin_rh)) then - self%origin_rh(:) = origin_rh(:) - end if - if (present(origin_vh)) then - self%origin_vh(:) = origin_vh(:) - end if - if (present(discard_time)) then - self%discard_time = discard_time - end if - if (present(discard_rh)) then - self%discard_rh(:) = discard_rh(:) - end if - if (present(discard_vh)) then - self%discard_vh(:) = discard_vh(:) - end if - if (present(discard_body_id)) then - self%discard_body_id = discard_body_id - end if - - return - end subroutine util_set_particle_info - - - module subroutine util_set_renc_I4B(self, scale) - !! author: David A. Minton - !! - !! Sets the critical radius for encounter given an input scale factor - !! - implicit none - ! Arguments - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - integer(I4B), intent(in) :: scale !! Input scale factor (multiplier of Hill's sphere size) - - associate(pl => self, npl => self%nbody) - pl%renc(1:npl) = pl%rhill(1:npl) * scale - end associate - - return - end subroutine util_set_renc_I4B - - - module subroutine util_set_renc_DP(self, scale) - !! author: David A. Minton - !! - !! Sets the critical radius for encounter given an input scale factor - !! - implicit none - ! Arguments - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - real(DP), intent(in) :: scale !! Input scale factor (multiplier of Hill's sphere size) - - associate(pl => self, npl => self%nbody) - pl%renc(1:npl) = pl%rhill(1:npl) * scale - end associate - - return - end subroutine util_set_renc_DP - - - module subroutine util_set_rhill(self,cb) - !! author: David A. Minton - !! - !! Sets the value of the Hill's radius - implicit none - ! Arguments - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object - - if (self%nbody == 0) return - - call self%xv2el(cb) - self%rhill(1:self%nbody) = self%a(1:self%nbody) * (self%Gmass(1:self%nbody) / cb%Gmass / 3)**THIRD - - return - end subroutine util_set_rhill - - - module subroutine util_set_rhill_approximate(self,cb) - !! author: David A. Minton - !! - !! Sets the approximate value of the Hill's radius using the heliocentric radius instead of computing the semimajor axis - implicit none - ! Arguments - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - class(swiftest_cb), intent(inout) :: cb !! Swiftest central body object - ! Internals - real(DP), dimension(:), allocatable :: rh - - if (self%nbody == 0) return - - rh(1:self%nbody) = .mag. self%rh(:,1:self%nbody) - self%rhill(1:self%nbody) = rh(1:self%nbody) * (self%Gmass(1:self%nbody) / cb%Gmass / 3)**THIRD - - return - end subroutine util_set_rhill_approximate - -end submodule s_util_set \ No newline at end of file diff --git a/src/util/util_snapshot.f90 b/src/util/util_snapshot.f90 deleted file mode 100644 index c3a98855b..000000000 --- a/src/util/util_snapshot.f90 +++ /dev/null @@ -1,36 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule(swiftest_classes) s_util_snapshot - use swiftest -contains - - module subroutine util_snapshot_system(self, param, system, t, arg) - !! author: David A. Minton - !! - !! Takes a snapshot of the system for later file storage - implicit none - ! Arguments - class(swiftest_storage(*)), intent(inout) :: self !! Swiftest storage object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - class(swiftest_nbody_system), intent(inout) :: system !! Swiftest nbody system object to store - real(DP), intent(in), optional :: t !! Time of snapshot if different from system time - character(*), intent(in), optional :: arg !! Optional argument (needed for extended storage type used in collision snapshots) - - self%iframe = self%iframe + 1 - self%nt = self%iframe - self%frame(self%iframe) = system ! Store a snapshot of the system for posterity - self%nid = self%nid + 1 ! Central body - if (allocated(system%pl)) self%nid = self%nid + system%pl%nbody - if (allocated(system%tp)) self%nid = self%nid + system%tp%nbody - - return - end subroutine util_snapshot_system - -end submodule s_util_snapshot \ No newline at end of file diff --git a/src/util/util_solve.f90 b/src/util/util_solve.f90 deleted file mode 100644 index 2480eae46..000000000 --- a/src/util/util_solve.f90 +++ /dev/null @@ -1,237 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule(swiftest_classes) s_util_solve - use swiftest -contains - - module function util_solve_linear_system_d(A,b,n,lerr) result(x) - !! Author: David A. Minton - !! - !! Solves the linear equation of the form A*x = b for x. - !! A is an (n,n) arrays - !! x and b are (n) arrays - !! Uses Gaussian elimination, so will have issues if system is ill-conditioned. - !! Uses quad precision intermidiate values, so works best on small arrays. - use, intrinsic :: ieee_exceptions - implicit none - ! Arguments - integer(I4B), intent(in) :: n - real(DP), dimension(:,:), intent(in) :: A - real(DP), dimension(:), intent(in) :: b - logical, intent(out) :: lerr - ! Result - real(DP), dimension(n) :: x - ! Internals - real(QP), dimension(:), allocatable :: qx - type(ieee_status_type) :: original_fpe_status - logical, dimension(:), allocatable :: fpe_flag - - call ieee_get_status(original_fpe_status) ! Save the original floating point exception status - call ieee_set_flag(ieee_all, .false.) ! Set all flags to quiet - allocate(fpe_flag(size(ieee_usual))) - - qx = solve_wbs(ge_wpp(real(A, kind=QP), real(b, kind=QP))) - - call ieee_get_flag(ieee_usual, fpe_flag) - lerr = any(fpe_flag) - if (lerr .or. (any(abs(qx) > huge(x))) .or. (any(abs(qx) < tiny(x)))) then - x = 0.0_DP - else - x = real(qx, kind=DP) - end if - call ieee_set_status(original_fpe_status) - - return - end function util_solve_linear_system_d - - module function util_solve_linear_system_q(A,b,n,lerr) result(x) - !! Author: David A. Minton - !! - !! Solves the linear equation of the form A*x = b for x. - !! A is an (n,n) arrays - !! x and b are (n) arrays - !! Uses Gaussian elimination, so will have issues if system is ill-conditioned. - !! Uses quad precision intermidiate values, so works best on small arrays. - use, intrinsic :: ieee_exceptions - implicit none - ! Arguments - integer(I4B), intent(in) :: n - real(QP), dimension(:,:), intent(in) :: A - real(QP), dimension(:), intent(in) :: b - logical, intent(out) :: lerr - ! Result - real(QP), dimension(n) :: x - ! Internals - type(ieee_status_type) :: original_fpe_status - logical, dimension(:), allocatable :: fpe_flag - - call ieee_get_status(original_fpe_status) ! Save the original floating point exception status - call ieee_set_flag(ieee_all, .false.) ! Set all flags to quiet - allocate(fpe_flag(size(ieee_usual))) - - x = solve_wbs(ge_wpp(A, b)) - - call ieee_get_flag(ieee_usual, fpe_flag) - lerr = any(fpe_flag) - if (lerr) x = 0.0_DP - call ieee_set_status(original_fpe_status) - - return - end function util_solve_linear_system_q - - function solve_wbs(u) result(x) ! solve with backward substitution - !! Based on code available on Rosetta Code: https://rosettacode.org/wiki/Gaussian_elimination#Fortran - use, intrinsic :: ieee_exceptions - use swiftest - implicit none - ! Arguments - real(QP), intent(in), dimension(:,:), allocatable :: u - ! Result - real(QP), dimension(:), allocatable :: x - ! Internals - integer(I4B) :: i,n - - n = size(u, 1) - if (allocated(x)) deallocate(x) - if (.not.allocated(x)) allocate(x(n)) - if (any(abs(u) < tiny(1._DP)) .or. any(abs(u) > huge(1._DP))) then - x(:) = 0._DP - return - end if - call ieee_set_halting_mode(ieee_divide_by_zero, .false.) - do i = n, 1, -1 - x(i) = (u(i, n + 1) - sum(u(i, i + 1:n) * x(i + 1:n))) / u(i, i) - end do - return - end function solve_wbs - - function ge_wpp(A, b) result(u) ! gaussian eliminate with partial pivoting - !! Solve Ax=b using Gaussian elimination then backwards substitution. - !! A being an n by n matrix. - !! x and b are n by 1 vectors. - !! Based on code available on Rosetta Code: https://rosettacode.org/wiki/Gaussian_elimination#Fortran - use, intrinsic :: ieee_exceptions - use swiftest - implicit none - ! Arguments - real(QP), dimension(:,:), intent(in) :: A - real(QP), dimension(:), intent(in) :: b - ! Result - real(QP), dimension(:,:), allocatable :: u - ! Internals - integer(I4B) :: i,j,n,p - real(QP) :: upi - - n = size(a, 1) - allocate(u(n, (n + 1))) - u = reshape([A, b], [n, n + 1]) - call ieee_set_halting_mode(ieee_divide_by_zero, .false.) - do j = 1, n - p = maxloc(abs(u(j:n, j)), 1) + j - 1 ! maxloc returns indices between (1, n - j + 1) - if (p /= j) u([p, j], j) = u([j, p], j) - u(j + 1:, j) = u(j + 1:, j) / u(j, j) - do i = j + 1, n + 1 - upi = u(p, i) - if (p /= j) u([p, j], i) = u([j, p], i) - u(j + 1:n, i) = u(j + 1:n, i) - upi * u(j + 1:n, j) - end do - end do - return - end function ge_wpp - - module function util_solve_rkf45(f, y0in, t1, dt0, tol) result(y1) - !! author: David A. Minton - !! - !! Implements the 4th order Runge-Kutta-Fehlberg ODE solver for initial value problems of the form f=dy/dt, y0 = y(t=0), solving for y1 = y(t=t1). Uses a 5th order adaptive step size control. - !! Uses a lambda function object as defined in the lambda_function module - implicit none - ! Arguments - class(lambda_obj), intent(inout) :: f !! lambda function object that has been initialized to be a function of derivatives. The object will return with components lastarg and lasteval set - real(DP), dimension(:), intent(in) :: y0in !! Initial value at t=0 - real(DP), intent(in) :: t1 !! Final time - real(DP), intent(in) :: dt0 !! Initial step size guess - real(DP), intent(in) :: tol !! Tolerance on solution - ! Result - real(DP), dimension(:), allocatable :: y1 !! Final result - ! Internals - integer(I4B), parameter :: MAXREDUX = 1000 !! Maximum number of times step size can be reduced - real(DP), parameter :: DTFAC = 0.95_DP !! Step size reduction safety factor (Value just under 1.0 to prevent adaptive step size control from discarding steps too aggressively) - integer(I4B), parameter :: RKS = 6 !! Number of RK stages - real(DP), dimension(RKS, RKS - 1), parameter :: rkf45_btab = reshape( & !! Butcher tableau for Runge-Kutta-Fehlberg method - (/ 1./4., 1./4., 0., 0., 0., 0.,& - 3./8., 3./32., 9./32., 0., 0., 0.,& - 12./13., 1932./2197., -7200./2197., 7296./2197., 0., 0.,& - 1., 439./216., -8., 3680./513., -845./4104., 0.,& - 1./2., -8./27., 2., -3544./2565., 1859./4104., -11./40./), shape(rkf45_btab)) - real(DP), dimension(RKS), parameter :: rkf4_coeff = (/ 25./216., 0., 1408./2565. , 2197./4104. , -1./5., 0. /) - real(DP), dimension(RKS), parameter :: rkf5_coeff = (/ 16./135., 0., 6656./12825., 28561./56430., -9./50., 2./55. /) - real(DP), dimension(:, :), allocatable :: k !! Runge-Kutta coefficient vector - real(DP), dimension(:), allocatable :: ynorm !! Normalized y value used for adaptive step size control - real(DP), dimension(:), allocatable :: y0 !! Value of y at the beginning of each substep - integer(I4B) :: Nvar !! Number of variables in problem - integer(I4B) :: rkn !! Runge-Kutta loop index - real(DP) :: t, x1, dt, trem !! Current time, step size and total time remaining - real(DP) :: s, yerr, yscale !! Step size reduction factor, error in dependent variable, and error scale factor - integer(I4B) :: i - - allocate(y0, source=y0in) - allocate(y1, mold=y0) - allocate(ynorm, mold=y0) - Nvar = size(y0) - allocate(k(Nvar, RKS)) - - dt = dt0 - - trem = t1 - t = 0._DP - do - yscale = norm2(y0(:)) - do i = 1, MAXREDUX - select type(f) - class is (lambda_obj_tvar) - do rkn = 1, RKS - y1(:) = y0(:) + matmul(k(:, 1:rkn - 1), rkf45_btab(2:rkn, rkn - 1)) - if (rkn == 1) then - x1 = t - else - x1 = t + rkf45_btab(1,rkn-1) - end if - k(:, rkn) = dt * f%evalt(y1(:), t) - end do - class is (lambda_obj) - do rkn = 1, RKS - y1(:) = y0(:) + matmul(k(:, 1:rkn - 1), rkf45_btab(2:rkn, rkn - 1)) - k(:, rkn) = dt * f%eval(y1(:)) - end do - end select - ! Now determine if the step size needs adjusting - ynorm(:) = matmul(k(:,:), (rkf5_coeff(:) - rkf4_coeff(:))) / yscale - yerr = norm2(ynorm(:)) - s = (tol / (2 * yerr))**(0.25_DP) - dt = min(s * DTFAC * dt, trem) ! Alter step size either up or down, but never bigger than the remaining time - if (s >= 1.0_DP) exit ! Good step! - if (i == MAXREDUX) then - write(*,*) "Something has gone wrong in util_solve_rkf45!! Step size reduction has gone too far this time!" - call util_exit(FAILURE) - end if - end do - - ! Compute new value then step ahead in time - y1(:) = y0(:) + matmul(k(:, :), rkf4_coeff(:)) - trem = trem - dt - t = t + dt - if (trem <= 0._DP) exit - y0(:) = y1(:) - end do - - return - end function util_solve_rkf45 - -end submodule s_util_solve \ No newline at end of file diff --git a/src/util/util_sort.f90 b/src/util/util_sort.f90 deleted file mode 100644 index 6b48103d5..000000000 --- a/src/util/util_sort.f90 +++ /dev/null @@ -1,1007 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule (swiftest_classes) s_util_sort - use swiftest -contains - - module subroutine util_sort_body(self, sortby, ascending) - !! author: David A. Minton - !! - !! Sort a Swiftest body structure in-place. - !! sortby is a string indicating which array component to sort. - implicit none - ! Arguments - class(swiftest_body), intent(inout) :: self !! Swiftest body object - character(*), intent(in) :: sortby !! Sorting attribute - logical, intent(in) :: ascending !! Logical flag indicating whether or not the sorting should be in ascending or descending order - ! Internals - integer(I4B), dimension(:), allocatable :: ind - integer(I4B) :: direction - - if (self%nbody == 0) return - - if (ascending) then - direction = 1 - else - direction = -1 - end if - - associate(body => self, n => self%nbody) - select case(sortby) - case("id") - call util_sort(direction * body%id(1:n), ind) - case("status") - call util_sort(direction * body%status(1:n), ind) - case("ir3h") - call util_sort(direction * body%ir3h(1:n), ind) - case("a") - call util_sort(direction * body%a(1:n), ind) - case("e") - call util_sort(direction * body%e(1:n), ind) - case("inc") - call util_sort(direction * body%inc(1:n), ind) - case("capom") - call util_sort(direction * body%capom(1:n), ind) - case("mu") - call util_sort(direction * body%mu(1:n), ind) - case("lfirst", "nbody", "ldiscard", "rh", "vh", "rb", "vb", "ah", "aobl", "atide", "agr") - write(*,*) 'Cannot sort by ' // trim(adjustl(sortby)) // '. Component not sortable!' - case default - write(*,*) 'Cannot sort by ' // trim(adjustl(sortby)) // '. Component not found!' - return - end select - - call body%rearrange(ind) - - end associate - - return - end subroutine util_sort_body - - - pure module subroutine util_sort_dp(arr) - !! author: David A. Minton - !! - !! Sort input DP precision array in place into ascending numerical order using quicksort. - !! - implicit none - ! Arguments - real(DP), dimension(:), intent(inout) :: arr - - call qsort_DP(arr) - - return - end subroutine util_sort_dp - - - pure module subroutine util_sort_index_dp(arr, ind) - !! author: David A. Minton - !! - !! Sort input DP precision array by index in ascending numerical order using quick sort. - !! This algorithm works well for partially sorted arrays (which is usually the case here). - !! If ind is supplied already allocated, we assume it is an existing index array (e.g. a previously - !! sorted array). If it is not allocated, this subroutine allocates it. - !! - implicit none - ! Arguments - real(DP), dimension(:), intent(in) :: arr - integer(I4B), dimension(:), allocatable, intent(inout) :: ind - ! Internals - integer(I4B) :: n, i - real(DP), dimension(:), allocatable :: tmparr - - n = size(arr) - if (.not.allocated(ind)) then - allocate(ind(n)) - ind = [(i, i=1, n)] - end if - allocate(tmparr, mold=arr) - tmparr(:) = arr(ind(:)) - call qsort_DP(tmparr, ind) - - return - end subroutine util_sort_index_dp - - - recursive pure subroutine qsort_DP(arr, ind) - !! author: David A. Minton - !! - !! Sort input DP precision array by index in ascending numerical order using quicksort sort. - !! - implicit none - ! Arguments - real(DP), dimension(:), intent(inout) :: arr - integer(I4B),dimension(:),intent(out), optional :: ind - !! Internals - integer :: iq - - if (size(arr) > 1) then - if (present(ind)) then - call partition_DP(arr, iq, ind) - call qsort_DP(arr(:iq-1),ind(:iq-1)) - call qsort_DP(arr(iq:), ind(iq:)) - else - call partition_DP(arr, iq) - call qsort_DP(arr(:iq-1)) - call qsort_DP(arr(iq:)) - end if - end if - - return - end subroutine qsort_DP - - - pure subroutine partition_DP(arr, marker, ind) - !! author: David A. Minton - !! - !! Partition function for quicksort on DP type - !! - implicit none - ! Arguments - real(DP), intent(inout), dimension(:) :: arr - integer(I4B), intent(inout), dimension(:), optional :: ind - integer(I4B), intent(out) :: marker - ! Internals - integer(I4B) :: i, j, itmp, narr, ipiv - real(DP) :: temp - real(DP) :: x ! pivot point - - narr = size(arr) - - ! Get center as pivot, as this is likely partially sorted - ipiv = narr / 2 - x = arr(ipiv) - i = 0 - j = narr + 1 - - do - j = j - 1 - do - if (arr(j) <= x) exit - j = j - 1 - end do - i = i + 1 - do - if (arr(i) >= x) exit - i = i + 1 - end do - if (i < j) then - ! exchange A(i) and A(j) - temp = arr(i) - arr(i) = arr(j) - arr(j) = temp - if (present(ind)) then - itmp = ind(i) - ind(i) = ind(j) - ind(j) = itmp - end if - else if (i == j) then - marker = i + 1 - return - else - marker = i - return - endif - end do - - return - end subroutine partition_DP - - - pure module subroutine util_sort_i4b(arr) - !! author: David A. Minton - !! - !! Sort input integer array in place into ascending numerical order using quick sort. - !! This algorithm works well for partially sorted arrays (which is usually the case here) - !! - implicit none - ! Arguments - integer(I4B), dimension(:), intent(inout) :: arr - - call qsort_I4B(arr) - - return - end subroutine util_sort_i4b - - - pure module subroutine util_sort_index_I4B(arr, ind) - !! author: David A. Minton - !! - !! Sort input integer array by index in ascending numerical order using quicksort. - !! If ind is supplied already allocated, we assume it is an existing index array (e.g. a previously - !! sorted array). If it is not allocated, this subroutine allocates it. - !! - implicit none - ! Arguments - integer(I4B), dimension(:), intent(in) :: arr - integer(I4B), dimension(:), allocatable, intent(inout) :: ind - ! Internals - integer(I4B) :: n, i - integer(I4B), dimension(:), allocatable :: tmparr - - n = size(arr) - if (.not.allocated(ind)) then - allocate(ind(n)) - ind = [(i, i=1, n)] - end if - allocate(tmparr, mold=arr) - tmparr(:) = arr(ind(:)) - call qsort_I4B(tmparr, ind) - - return - end subroutine util_sort_index_I4B - - - pure module subroutine util_sort_index_I4B_I8Bind(arr, ind) - !! author: David A. Minton - !! - !! Sort input integer array by index in ascending numerical order using quicksort. - !! If ind is supplied already allocated, we assume it is an existing index array (e.g. a previously - !! sorted array). If it is not allocated, this subroutine allocates it. - !! - implicit none - ! Arguments - integer(I4B), dimension(:), intent(in) :: arr - integer(I8B), dimension(:), allocatable, intent(inout) :: ind - ! Internals - integer(I8B) :: n, i - integer(I4B), dimension(:), allocatable :: tmparr - - n = size(arr) - if (.not.allocated(ind)) then - allocate(ind(n)) - ind = [(i, i=1_I8B, n)] - end if - allocate(tmparr, mold=arr) - tmparr(:) = arr(ind(:)) - call qsort_I4B_I8Bind(tmparr, ind) - - return - end subroutine util_sort_index_I4B_I8Bind - - - recursive pure subroutine qsort_I4B(arr, ind) - !! author: David A. Minton - !! - !! Sort input I4B array by index in ascending numerical order using quicksort. - !! - implicit none - ! Arguments - integer(I4B), dimension(:), intent(inout) :: arr - integer(I4B), dimension(:), intent(out), optional :: ind - ! Internals - integer(I4B) :: iq - - if (size(arr) > 1) then - if (present(ind)) then - call partition_I4B(arr, iq, ind) - call qsort_I4B(arr(:iq-1),ind(:iq-1)) - call qsort_I4B(arr(iq:), ind(iq:)) - else - call partition_I4B(arr, iq) - call qsort_I4B(arr(:iq-1)) - call qsort_I4B(arr(iq:)) - end if - end if - - return - end subroutine qsort_I4B - - recursive pure subroutine qsort_I4B_I8Bind(arr, ind) - !! author: David A. Minton - !! - !! Sort input I4B array by index in ascending numerical order using quicksort. - !! - implicit none - ! Arguments - integer(I4B), dimension(:), intent(inout) :: arr - integer(I8B), dimension(:), intent(out), optional :: ind - ! Internals - integer(I8B) :: iq - - if (size(arr) > 1_I8B) then - if (present(ind)) then - call partition_I4B_I8Bind(arr, iq, ind) - call qsort_I4B_I8Bind(arr(:iq-1_I8B),ind(:iq-1_I8B)) - call qsort_I4B_I8Bind(arr(iq:), ind(iq:)) - else - call partition_I4B_I8Bind(arr, iq) - call qsort_I4B_I8Bind(arr(:iq-1_I8B)) - call qsort_I4B_I8Bind(arr(iq:)) - end if - end if - - return - end subroutine qsort_I4B_I8Bind - - - recursive pure subroutine qsort_I8B_I8Bind(arr, ind) - !! author: David A. Minton - !! - !! Sort input I8B array by index in ascending numerical order using quicksort. - !! - implicit none - ! Arguments - integer(I8B), dimension(:), intent(inout) :: arr - integer(I8B), dimension(:), intent(out), optional :: ind - ! Internals - integer(I8B) :: iq - - if (size(arr) > 1_I8B) then - if (present(ind)) then - call partition_I8B_I8Bind(arr, iq, ind) - call qsort_I8B_I8Bind(arr(:iq-1_I8B),ind(:iq-1_I8B)) - call qsort_I8B_I8Bind(arr(iq:), ind(iq:)) - else - call partition_I8B_I8Bind(arr, iq) - call qsort_I8B_I8Bind(arr(:iq-1_I8B)) - call qsort_I8B_I8Bind(arr(iq:)) - end if - end if - - return - end subroutine qsort_I8B_I8Bind - - - pure subroutine partition_I4B(arr, marker, ind) - !! author: David A. Minton - !! - !! Partition function for quicksort on I4B type - !! - implicit none - ! Arguments - integer(I4B), intent(inout), dimension(:) :: arr - integer(I4B), intent(inout), dimension(:), optional :: ind - integer(I4B), intent(out) :: marker - ! Internals - integer(I4B) :: i, j, itmp, narr, ipiv - integer(I4B) :: temp - integer(I4B) :: x ! pivot point - - narr = size(arr) - - ! Get center as pivot, as this is likely partially sorted - ipiv = narr / 2 - x = arr(ipiv) - i = 0 - j = narr + 1 - - do - j = j - 1 - do - if (arr(j) <= x) exit - j = j - 1 - end do - i = i + 1 - do - if (arr(i) >= x) exit - i = i + 1 - end do - if (i < j) then - ! exchange A(i) and A(j) - temp = arr(i) - arr(i) = arr(j) - arr(j) = temp - if (present(ind)) then - itmp = ind(i) - ind(i) = ind(j) - ind(j) = itmp - end if - else if (i == j) then - marker = i + 1 - return - else - marker = i - return - endif - end do - - return - end subroutine partition_I4B - - pure subroutine partition_I4B_I8Bind(arr, marker, ind) - !! author: David A. Minton - !! - !! Partition function for quicksort on I4B type - !! - implicit none - ! Arguments - integer(I4B), intent(inout), dimension(:) :: arr - integer(I8B), intent(inout), dimension(:), optional :: ind - integer(I8B), intent(out) :: marker - ! Internals - integer(I8B) :: i, j, itmp, narr, ipiv - integer(I4B) :: temp - integer(I8B) :: x ! pivot point - - narr = size(arr) - - ! Get center as pivot, as this is likely partially sorted - ipiv = narr / 2_I8B - x = arr(ipiv) - i = 0_I8B - j = narr + 1_I8B - - do - j = j - 1_I8B - do - if (arr(j) <= x) exit - j = j - 1_I8B - end do - i = i + 1_I8B - do - if (arr(i) >= x) exit - i = i + 1_I8B - end do - if (i < j) then - ! exchange A(i) and A(j) - temp = arr(i) - arr(i) = arr(j) - arr(j) = temp - if (present(ind)) then - itmp = ind(i) - ind(i) = ind(j) - ind(j) = itmp - end if - else if (i == j) then - marker = i + 1_I8B - return - else - marker = i - return - endif - end do - - return - end subroutine partition_I4B_I8Bind - - pure subroutine partition_I8B_I8Bind(arr, marker, ind) - !! author: David A. Minton - !! - !! Partition function for quicksort on I8B type with I8B index - !! - implicit none - ! Arguments - integer(I8B), intent(inout), dimension(:) :: arr - integer(I8B), intent(inout), dimension(:), optional :: ind - integer(I8B), intent(out) :: marker - ! Internals - integer(I8B) :: i, j, itmp, narr, ipiv - integer(I8B) :: temp - integer(I8B) :: x ! pivot point - - narr = size(arr) - - ! Get center as pivot, as this is likely partially sorted - ipiv = narr / 2_I8B - x = arr(ipiv) - i = 0_I8B - j = narr + 1_I8B - - do - j = j - 1_I8B - do - if (arr(j) <= x) exit - j = j - 1_I8B - end do - i = i + 1_I8B - do - if (arr(i) >= x) exit - i = i + 1_I8B - end do - if (i < j) then - ! exchange A(i) and A(j) - temp = arr(i) - arr(i) = arr(j) - arr(j) = temp - if (present(ind)) then - itmp = ind(i) - ind(i) = ind(j) - ind(j) = itmp - end if - else if (i == j) then - marker = i + 1_I8B - return - else - marker = i - return - endif - end do - - return - end subroutine partition_I8B_I8Bind - - - pure module subroutine util_sort_sp(arr) - !! author: David A. Minton - !! - !! Sort input DP precision array in place into ascending numerical order using quicksort. - !! - implicit none - ! Arguments - real(SP), dimension(:), intent(inout) :: arr - - call qsort_SP(arr) - - return - end subroutine util_sort_sp - - - pure module subroutine util_sort_index_sp(arr, ind) - !! author: David A. Minton - !! - !! Sort input DP precision array by index in ascending numerical order using quicksort. - !! If ind is supplied already allocated, we assume it is an existing index array (e.g. a previously - !! sorted array). If it is not allocated, this subroutine allocates it. - !! - implicit none - ! Arguments - real(SP), dimension(:), intent(in) :: arr - integer(I4B), dimension(:), allocatable, intent(inout) :: ind - ! Internals - integer(I4B) :: n, i - real(SP), dimension(:), allocatable :: tmparr - - n = size(arr) - if (.not.allocated(ind)) then - allocate(ind(n)) - ind = [(i, i=1, n)] - end if - allocate(tmparr, mold=arr) - tmparr(:) = arr(ind(:)) - call qsort_SP(tmparr, ind) - - return - end subroutine util_sort_index_sp - - - recursive pure subroutine qsort_SP(arr, ind) - !! author: David A. Minton - !! - !! Sort input DP precision array by index in ascending numerical order using quicksort. - !! - implicit none - ! Arguments - real(SP), dimension(:), intent(inout) :: arr - integer(I4B),dimension(:),intent(out), optional :: ind - !! Internals - integer :: iq - - if (size(arr) > 1) then - if (present(ind)) then - call partition_SP(arr, iq, ind) - call qsort_SP(arr(:iq-1),ind(:iq-1)) - call qsort_SP(arr(iq:), ind(iq:)) - else - call partition_SP(arr, iq) - call qsort_SP(arr(:iq-1)) - call qsort_SP(arr(iq:)) - end if - end if - - return - end subroutine qsort_SP - - - pure subroutine partition_SP(arr, marker, ind) - !! author: David A. Minton - !! - !! Partition function for quicksort on SP type - !! - implicit none - ! Arguments - real(SP), intent(inout), dimension(:) :: arr - integer(I4B), intent(inout), dimension(:), optional :: ind - integer(I4B), intent(out) :: marker - ! Internals - integer(I4B) :: i, j, itmp, narr, ipiv - real(SP) :: temp - real(SP) :: x ! pivot point - - narr = size(arr) - - ! Get center as pivot, as this is likely partially sorted - ipiv = narr / 2 - x = arr(ipiv) - i = 0 - j = narr + 1 - - do - j = j - 1 - do - if (arr(j) <= x) exit - j = j - 1 - end do - i = i + 1 - do - if (arr(i) >= x) exit - i = i + 1 - end do - if (i < j) then - ! exchange A(i) and A(j) - temp = arr(i) - arr(i) = arr(j) - arr(j) = temp - if (present(ind)) then - itmp = ind(i) - ind(i) = ind(j) - ind(j) = itmp - end if - else if (i == j) then - marker = i + 1 - return - else - marker = i - return - endif - end do - - return - end subroutine partition_SP - - - module subroutine util_sort_pl(self, sortby, ascending) - !! author: David A. Minton - !! - !! Sort a Swiftest massive body object in-place. - !! sortby is a string indicating which array component to sort. - implicit none - ! Arguments - class(swiftest_pl), intent(inout) :: self !! Swiftest massive body object - character(*), intent(in) :: sortby !! Sorting attribute - logical, intent(in) :: ascending !! Logical flag indicating whether or not the sorting should be in ascending or descending order - ! Internals - integer(I4B), dimension(:), allocatable :: ind - integer(I4B) :: direction - - if (self%nbody == 0) return - - if (ascending) then - direction = 1 - else - direction = -1 - end if - - associate(pl => self, npl => self%nbody) - select case(sortby) - case("Gmass","mass") - call util_sort(direction * pl%Gmass(1:npl), ind) - case("rhill") - call util_sort(direction * pl%rhill(1:npl), ind) - case("renc") - call util_sort(direction * pl%renc(1:npl), ind) - case("radius") - call util_sort(direction * pl%radius(1:npl), ind) - case("density") - call util_sort(direction * pl%density(1:npl), ind) - case("k2") - call util_sort(direction * pl%k2(1:npl), ind) - case("Q") - call util_sort(direction * pl%Q(1:npl), ind) - case("tlag") - call util_sort(direction * pl%tlag(1:npl), ind) - case("rbeg", "xend", "vbeg", "Ip", "rot", "k_plpl", "nplpl") - write(*,*) 'Cannot sort by ' // trim(adjustl(sortby)) // '. Component not sortable!' - case default ! Look for components in the parent class - call util_sort_body(pl, sortby, ascending) - return - end select - - call pl%rearrange(ind) - - end associate - - return - end subroutine util_sort_pl - - - module subroutine util_sort_tp(self, sortby, ascending) - !! author: David A. Minton - !! - !! Sort a Swiftest test particle object in-place. - !! sortby is a string indicating which array component to sort. - implicit none - ! Arguments - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle object - character(*), intent(in) :: sortby !! Sorting attribute - logical, intent(in) :: ascending !! Logical flag indicating whether or not the sorting should be in ascending or descending order - ! Internals - integer(I4B), dimension(:), allocatable :: ind - integer(I4B) :: direction - - if (self%nbody == 0) return - - if (ascending) then - direction = 1 - else - direction = -1 - end if - - associate(tp => self, ntp => self%nbody) - select case(sortby) - case("peri") - call util_sort(direction * tp%peri(1:ntp), ind) - case("atp") - call util_sort(direction * tp%atp(1:ntp), ind) - case("isperi") - write(*,*) 'Cannot sort by ' // trim(adjustl(sortby)) // '. Component not sortable!' - case default ! Look for components in the parent class - call util_sort_body(tp, sortby, ascending) - return - end select - - call tp%rearrange(ind) - - end associate - - return - end subroutine util_sort_tp - - - module subroutine util_sort_rearrange_body(self, ind) - !! author: David A. Minton - !! - !! Rearrange Swiftest body structure in-place from an index list. - !! This is a helper utility used to make polymorphic sorting work on Swiftest structures. - implicit none - ! Arguments - class(swiftest_body), intent(inout) :: self !! Swiftest 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) - - associate(n => self%nbody) - call util_sort_rearrange(self%id, ind, n) - call util_sort_rearrange(self%info, ind, n) - call util_sort_rearrange(self%status, ind, n) - call util_sort_rearrange(self%ldiscard, ind, n) - call util_sort_rearrange(self%rh, ind, n) - call util_sort_rearrange(self%vh, ind, n) - call util_sort_rearrange(self%rb, ind, n) - call util_sort_rearrange(self%vb, ind, n) - call util_sort_rearrange(self%ah, ind, n) - call util_sort_rearrange(self%ir3h, ind, n) - call util_sort_rearrange(self%mu, ind, n) - call util_sort_rearrange(self%lmask, ind, n) - call util_sort_rearrange(self%a, ind, n) - call util_sort_rearrange(self%e, ind, n) - call util_sort_rearrange(self%inc, ind, n) - call util_sort_rearrange(self%capom, ind, n) - call util_sort_rearrange(self%omega, ind, n) - call util_sort_rearrange(self%capm, ind, n) - call util_sort_rearrange(self%aobl, ind, n) - call util_sort_rearrange(self%atide, ind, n) - call util_sort_rearrange(self%agr, ind, n) - end associate - - return - end subroutine util_sort_rearrange_body - - - pure module subroutine util_sort_rearrange_arr_char_string(arr, ind, n) - !! author: David A. Minton - !! - !! Rearrange a single array of character string in-place from an index list. - implicit none - ! Arguments - character(len=STRMAX), dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange - ! Internals - character(len=STRMAX), dimension(:), allocatable :: tmp !! Temporary copy of arry used during rearrange operation - - if (.not. allocated(arr) .or. n <= 0) return - allocate(tmp, mold=arr) - tmp(1:n) = arr(ind) - call move_alloc(tmp, arr) - - return - end subroutine util_sort_rearrange_arr_char_string - - - pure module subroutine util_sort_rearrange_arr_DP(arr, ind, n) - !! author: David A. Minton - !! - !! Rearrange a single array of DP type in-place from an index list. - implicit none - ! Arguments - real(DP), dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange - ! Internals - real(DP), dimension(:), allocatable :: tmp !! Temporary copy of array used during rearrange operation - - if (.not. allocated(arr) .or. n <= 0) return - allocate(tmp, mold=arr) - tmp(1:n) = arr(ind) - call move_alloc(tmp, arr) - - return - end subroutine util_sort_rearrange_arr_DP - - - pure module subroutine util_sort_rearrange_arr_DPvec(arr, ind, n) - !! author: David A. Minton - !! - !! Rearrange a single array of (NDIM,n) DP-type vectors in-place from an index list. - implicit none - ! Arguments - real(DP), dimension(:,:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange - ! Internals - real(DP), dimension(:,:), allocatable :: tmp !! Temporary copy of array used during rearrange operation - - if (.not. allocated(arr) .or. n <= 0) return - allocate(tmp, mold=arr) - tmp(:,1:n) = arr(:, ind) - call move_alloc(tmp, arr) - - return - end subroutine util_sort_rearrange_arr_DPvec - - - pure module subroutine util_sort_rearrange_arr_I4B(arr, ind, n) - !! author: David A. Minton - !! - !! Rearrange a single array of integers in-place from an index list. - implicit none - ! Arguments - integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange - ! Internals - integer(I4B), dimension(:), allocatable :: tmp !! Temporary copy of array used during rearrange operation - - if (.not. allocated(arr) .or. n <= 0) return - allocate(tmp, mold=arr) - tmp(1:n) = arr(ind) - call move_alloc(tmp, arr) - - return - end subroutine util_sort_rearrange_arr_I4B - - pure module subroutine util_sort_rearrange_arr_I4B_I8Bind(arr, ind, n) - !! author: David A. Minton - !! - !! Rearrange a single array of integers in-place from an index list. - implicit none - ! Arguments - integer(I4B), dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I8B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I8B), intent(in) :: n !! Number of elements in arr and ind to rearrange - ! Internals - integer(I4B), dimension(:), allocatable :: tmp !! Temporary copy of array used during rearrange operation - - if (.not. allocated(arr) .or. n <= 0_I8B) return - allocate(tmp, mold=arr) - tmp(1:n) = arr(ind) - call move_alloc(tmp, arr) - - return - end subroutine util_sort_rearrange_arr_I4B_I8Bind - - - pure module subroutine util_sort_rearrange_arr_logical(arr, ind, n) - !! author: David A. Minton - !! - !! Rearrange a single array of logicals in-place from an index list. - implicit none - ! Arguments - logical, dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange - ! Internals - logical, dimension(:), allocatable :: tmp !! Temporary copy of array used during rearrange operation - - if (.not. allocated(arr) .or. n <= 0) return - allocate(tmp, mold=arr) - tmp(1:n) = arr(ind) - call move_alloc(tmp, arr) - - return - end subroutine util_sort_rearrange_arr_logical - - - pure module subroutine util_sort_rearrange_arr_logical_I8Bind(arr, ind, n) - !! author: David A. Minton - !! - !! Rearrange a single array of logicals in-place from an index list. - implicit none - ! Arguments - logical, dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I8B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I8B), intent(in) :: n !! Number of elements in arr and ind to rearrange - ! Internals - logical, dimension(:), allocatable :: tmp !! Temporary copy of array used during rearrange operation - - if (.not. allocated(arr) .or. n <= 0) return - allocate(tmp, mold=arr) - tmp(1:n) = arr(ind) - call move_alloc(tmp, arr) - - return - end subroutine util_sort_rearrange_arr_logical_I8Bind - - - module subroutine util_sort_rearrange_arr_info(arr, ind, n) - !! author: David A. Minton - !! - !! Rearrange a single array of particle information type in-place from an index list. - implicit none - ! Arguments - type(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: arr !! Destination array - integer(I4B), dimension(:), intent(in) :: ind !! Index to rearrange against - integer(I4B), intent(in) :: n !! Number of elements in arr and ind to rearrange - ! Internals - type(swiftest_particle_info), dimension(:), allocatable :: tmp !! Temporary copy of array used during rearrange operation - - if (.not. allocated(arr) .or. n <= 0) return - allocate(tmp, mold=arr) - - call util_copy_particle_info_arr(arr, tmp, ind) - call move_alloc(tmp, arr) - - return - end subroutine util_sort_rearrange_arr_info - - - module subroutine util_sort_rearrange_pl(self, ind) - !! author: David A. Minton - !! - !! Rearrange Swiftest massive body structure in-place from an index list. - !! This is a helper utility used to make polymorphic sorting work on Swiftest structures. - implicit none - class(swiftest_pl), intent(inout) :: self !! Swiftest 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) - - associate(pl => self, npl => self%nbody) - call util_sort_rearrange(pl%mass, ind, npl) - call util_sort_rearrange(pl%Gmass, ind, npl) - call util_sort_rearrange(pl%rhill, ind, npl) - call util_sort_rearrange(pl%rbeg, ind, npl) - call util_sort_rearrange(pl%vbeg, ind, npl) - call util_sort_rearrange(pl%radius, ind, npl) - call util_sort_rearrange(pl%density, ind, npl) - call util_sort_rearrange(pl%Ip, ind, npl) - call util_sort_rearrange(pl%rot, ind, npl) - call util_sort_rearrange(pl%k2, ind, npl) - call util_sort_rearrange(pl%Q, ind, npl) - call util_sort_rearrange(pl%tlag, ind, npl) - - if (allocated(pl%k_plpl)) deallocate(pl%k_plpl) - - call util_sort_rearrange_body(pl, ind) - end associate - - return - end subroutine util_sort_rearrange_pl - - - module subroutine util_sort_rearrange_tp(self, ind) - !! author: David A. Minton - !! - !! Rearrange Swiftest massive body structure in-place from an index list. - !! This is a helper utility used to make polymorphic sorting work on Swiftest structures. - implicit none - ! Arguments - class(swiftest_tp), intent(inout) :: self !! Swiftest test particle 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) - - associate(tp => self, ntp => self%nbody) - call util_sort_rearrange(tp%isperi, ind, ntp) - call util_sort_rearrange(tp%peri, ind, ntp) - call util_sort_rearrange(tp%atp, ind, ntp) - - call util_sort_rearrange_body(tp, ind) - end associate - - return - end subroutine util_sort_rearrange_tp - -end submodule s_util_sort diff --git a/src/util/util_spill.f90 b/src/util/util_spill.f90 deleted file mode 100644 index 1ba4b4a2f..000000000 --- a/src/util/util_spill.f90 +++ /dev/null @@ -1,440 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule (swiftest_classes) s_util_spill - use swiftest -contains - - module subroutine util_spill_arr_char_string(keeps, discards, lspill_list, ldestructive) - !! author: David A. Minton - !! - !! Performs a spill operation on a single array of type character strings - !! This is the inverse of a spill operation - implicit none - ! Arguments - character(len=STRMAX), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - character(len=STRMAX), dimension(:), allocatable, intent(inout) :: discards !! Array of discards - 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 - ! Internals - integer(I4B) :: nspill, nkeep, nlist - character(len=STRMAX), dimension(:), allocatable :: tmp !! Array of values to keep - - nkeep = count(.not.lspill_list(:)) - nspill = count(lspill_list(:)) - nlist = size(lspill_list(:)) - - if (.not.allocated(keeps) .or. nspill == 0) return - if (.not.allocated(discards)) then - allocate(discards(nspill)) - else if (size(discards) /= nspill) then - deallocate(discards) - allocate(discards(nspill)) - end if - - discards(:) = pack(keeps(1:nlist), lspill_list(1:nlist)) - if (ldestructive) then - if (nkeep > 0) then - allocate(tmp(nkeep)) - tmp(:) = pack(keeps(1:nlist), .not. lspill_list(1:nlist)) - call move_alloc(tmp, keeps) - else - deallocate(keeps) - end if - end if - - return - end subroutine util_spill_arr_char_string - - - module subroutine util_spill_arr_DP(keeps, discards, lspill_list, ldestructive) - !! author: David A. Minton - !! - !! Performs a spill operation on a single array of type DP - !! This is the inverse of a spill operation - implicit none - ! Arguments - real(DP), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - real(DP), 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 - ! Internals - integer(I4B) :: nspill, nkeep, nlist - real(DP), dimension(:), allocatable :: tmp !! Array of values to keep - - nkeep = count(.not.lspill_list(:)) - nspill = count(lspill_list(:)) - nlist = size(lspill_list(:)) - - if (.not.allocated(keeps) .or. nspill == 0) return - if (.not.allocated(discards)) then - allocate(discards(nspill)) - else if (size(discards) /= nspill) then - deallocate(discards) - allocate(discards(nspill)) - end if - - discards(:) = pack(keeps(1:nlist), lspill_list(1:nlist)) - if (ldestructive) then - if (nkeep > 0) then - allocate(tmp(nkeep)) - tmp(:) = pack(keeps(1:nlist), .not. lspill_list(1:nlist)) - call move_alloc(tmp, keeps) - else - deallocate(keeps) - end if - end if - - return - end subroutine util_spill_arr_DP - - - module subroutine util_spill_arr_DPvec(keeps, discards, lspill_list, ldestructive) - !! author: David A. Minton - !! - !! Performs a spill operation on a single array of DP vectors with shape (NDIM, n) - !! This is the inverse of a spill operation - implicit none - ! Arguments - real(DP), dimension(:,:), allocatable, intent(inout) :: keeps !! Array of values to keep - real(DP), dimension(:,:), allocatable, intent(inout) :: discards !! Array discards - 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 - ! Internals - integer(I4B) :: i, nspill, nkeep, nlist - real(DP), dimension(:,:), allocatable :: tmp !! Array of values to keep - - nkeep = count(.not.lspill_list(:)) - nspill = count(lspill_list(:)) - nlist = size(lspill_list(:)) - - if (.not.allocated(keeps) .or. nspill == 0) return - if (.not.allocated(discards)) then - allocate(discards(NDIM, nspill)) - else if (size(discards, dim=2) /= nspill) then - deallocate(discards) - allocate(discards(NDIM, nspill)) - end if - - do i = 1, NDIM - discards(i,:) = pack(keeps(i,1:nlist), lspill_list(1:nlist)) - end do - if (ldestructive) then - if (nkeep > 0) then - allocate(tmp(NDIM, nkeep)) - do i = 1, NDIM - tmp(i, :) = pack(keeps(i, 1:nlist), .not. lspill_list(1:nlist)) - end do - call move_alloc(tmp, keeps) - else - deallocate(keeps) - end if - end if - - return - end subroutine util_spill_arr_DPvec - - - module subroutine util_spill_arr_I4B(keeps, discards, lspill_list, ldestructive) - !! author: David A. Minton - !! - !! Performs a spill operation on a single array of type I4B - !! This is the inverse of a spill operation - implicit none - ! Arguments - integer(I4B), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - integer(I4B), dimension(:), allocatable, intent(inout) :: discards !! Array of discards - 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 - ! Internals - integer(I4B) :: nspill, nkeep, nlist - integer(I4B), dimension(:), allocatable :: tmp !! Array of values to keep - - nkeep = count(.not.lspill_list(:)) - nspill = count(lspill_list(:)) - nlist = size(lspill_list(:)) - - if (.not.allocated(keeps) .or. nspill == 0) return - if (.not.allocated(discards)) then - allocate(discards(nspill)) - else if (size(discards) /= nspill) then - deallocate(discards) - allocate(discards(nspill)) - end if - - discards(:) = pack(keeps(1:nlist), lspill_list(1:nlist)) - if (ldestructive) then - if (nkeep > 0) then - allocate(tmp(nkeep)) - tmp(:) = pack(keeps(1:nlist), .not. lspill_list(1:nlist)) - call move_alloc(tmp, keeps) - else - deallocate(keeps) - end if - end if - - return - end subroutine util_spill_arr_I4B - - - module subroutine util_spill_arr_I8B(keeps, discards, lspill_list, ldestructive) - !! author: David A. Minton - !! - !! Performs a spill operation on a single array of type I4B - !! This is the inverse of a spill operation - implicit none - ! Arguments - integer(I8B), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - integer(I8B), dimension(:), allocatable, intent(inout) :: discards !! Array of discards - 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 - ! Internals - integer(I4B) :: nspill, nkeep, nlist - integer(I8B), dimension(:), allocatable :: tmp !! Array of values to keep - - nkeep = count(.not.lspill_list(:)) - nspill = count(lspill_list(:)) - nlist = size(lspill_list(:)) - - if (.not.allocated(keeps) .or. nspill == 0) return - if (.not.allocated(discards)) then - allocate(discards(nspill)) - else if (size(discards) /= nspill) then - deallocate(discards) - allocate(discards(nspill)) - end if - - discards(:) = pack(keeps(1:nlist), lspill_list(1:nlist)) - if (ldestructive) then - if (nkeep > 0) then - allocate(tmp(nkeep)) - tmp(:) = pack(keeps(1:nlist), .not. lspill_list(1:nlist)) - call move_alloc(tmp, keeps) - else - deallocate(keeps) - end if - end if - - return - end subroutine util_spill_arr_I8B - - - module subroutine 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(swiftest_particle_info), dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - type(swiftest_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 - ! Internals - integer(I4B) :: i, nspill, nkeep, nlist - integer(I4B), dimension(:), allocatable :: idx - type(swiftest_particle_info), dimension(:), allocatable :: tmp - - nkeep = count(.not.lspill_list(:)) - nspill = count(lspill_list(:)) - nlist = size(lspill_list(:)) - - if (.not.allocated(keeps) .or. nspill == 0) return - if (.not.allocated(discards)) then - allocate(discards(nspill)) - else if (size(discards) /= nspill) then - deallocate(discards) - allocate(discards(nspill)) - end if - - allocate(idx(nspill)) - idx(:) = pack([(i, i = 1, nlist)], lspill_list) - call util_copy_particle_info_arr(keeps, discards, idx) - if (ldestructive) then - if (nkeep > 0) then - deallocate(idx) - allocate(idx(nkeep)) - allocate(tmp(nkeep)) - idx(:) = pack([(i, i = 1, nlist)], .not. lspill_list) - call util_copy_particle_info_arr(keeps, tmp, idx) - call move_alloc(tmp, keeps) - else - deallocate(keeps) - end if - end if - - return - end subroutine util_spill_arr_info - - - module subroutine util_spill_arr_logical(keeps, discards, lspill_list, ldestructive) - !! author: David A. Minton - !! - !! Performs a spill operation on a single array of logicals - !! This is the inverse of a spill operation - implicit none - ! Arguments - logical, dimension(:), allocatable, intent(inout) :: keeps !! Array of values to keep - logical, dimension(:), allocatable, intent(inout) :: discards !! Array of discards - 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 no - ! Internals - integer(I4B) :: nspill, nkeep, nlist - logical, dimension(:), allocatable :: tmp !! Array of values to keep - - nkeep = count(.not.lspill_list(:)) - nspill = count(lspill_list(:)) - nlist = size(lspill_list(:)) - - if (.not.allocated(keeps) .or. nspill == 0) return - if (.not.allocated(discards)) then - allocate(discards(nspill)) - else if (size(discards) /= nspill) then - deallocate(discards) - allocate(discards(nspill)) - end if - - discards(:) = pack(keeps(1:nlist), lspill_list(1:nlist)) - if (ldestructive) then - if (nkeep > 0) then - allocate(tmp(nkeep)) - tmp(:) = pack(keeps(1:nlist), .not. lspill_list(1:nlist)) - call move_alloc(tmp, keeps) - else - deallocate(keeps) - end if - end if - - return - end subroutine util_spill_arr_logical - - - module subroutine util_spill_body(self, discards, lspill_list, ldestructive) - !! author: David A. Minton - !! - !! Move spilled (discarded) Swiftest generic particle structure from active list to discard list - !! Adapted from David E. Kaufmann's Swifter routine whm_discard_spill.f90 - implicit none - ! Arguments - class(swiftest_body), intent(inout) :: self !! Swiftest generic 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 body by removing the discard list - ! Internals - integer(I4B) :: nbody_old - - ! 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) - - call util_spill(keeps%id, discards%id, lspill_list, ldestructive) - call util_spill(keeps%info, discards%info, lspill_list, ldestructive) - call util_spill(keeps%status, discards%status, lspill_list, ldestructive) - call util_spill(keeps%lmask, discards%lmask, lspill_list, ldestructive) - call util_spill(keeps%ldiscard, discards%ldiscard, lspill_list, ldestructive) - call util_spill(keeps%mu, discards%mu, lspill_list, ldestructive) - call util_spill(keeps%rh, discards%rh, lspill_list, ldestructive) - call util_spill(keeps%vh, discards%vh, lspill_list, ldestructive) - call util_spill(keeps%rb, discards%rb, lspill_list, ldestructive) - call util_spill(keeps%vb, discards%vb, lspill_list, ldestructive) - call util_spill(keeps%ah, discards%ah, lspill_list, ldestructive) - call util_spill(keeps%aobl, discards%aobl, lspill_list, ldestructive) - call util_spill(keeps%agr, discards%agr, lspill_list, ldestructive) - call util_spill(keeps%atide, discards%atide, lspill_list, ldestructive) - call util_spill(keeps%a, discards%a, lspill_list, ldestructive) - call util_spill(keeps%e, discards%e, lspill_list, ldestructive) - call util_spill(keeps%inc, discards%inc, lspill_list, ldestructive) - call util_spill(keeps%capom, discards%capom, lspill_list, ldestructive) - call util_spill(keeps%omega, discards%omega, lspill_list, ldestructive) - call util_spill(keeps%capm, discards%capm, lspill_list, ldestructive) - - nbody_old = keeps%nbody - - ! This is the base class, so will be the last to be called in the cascade. - ! Therefore we need to set the nbody values for both the keeps and discareds - discards%nbody = count(lspill_list(1:nbody_old)) - if (ldestructive) keeps%nbody = nbody_old- discards%nbody - end associate - - return - end subroutine util_spill_body - - - module subroutine util_spill_pl(self, discards, lspill_list, ldestructive) - !! author: David A. Minton - !! - !! Move spilled (discarded) Swiftest massive body structure from active list to discard list - !! Adapted from David E. Kaufmann's Swifter routine whm_discard_spill.f90 - implicit none - ! Arguments - class(swiftest_pl), intent(inout) :: self !! Swiftest 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 body by removing the discard list - - associate(keeps => self) - select type (discards) ! The standard requires us to select the type of both arguments in order to access all the components - class is (swiftest_pl) - !> Spill components specific to the massive body class - call util_spill(keeps%mass, discards%mass, lspill_list, ldestructive) - call util_spill(keeps%Gmass, discards%Gmass, lspill_list, ldestructive) - call util_spill(keeps%rhill, discards%rhill, lspill_list, ldestructive) - call util_spill(keeps%renc, discards%renc, lspill_list, ldestructive) - call util_spill(keeps%radius, discards%radius, lspill_list, ldestructive) - call util_spill(keeps%density, discards%density, lspill_list, ldestructive) - call util_spill(keeps%k2, discards%k2, lspill_list, ldestructive) - call util_spill(keeps%Q, discards%Q, lspill_list, ldestructive) - call util_spill(keeps%tlag, discards%tlag, lspill_list, ldestructive) - call util_spill(keeps%rbeg, discards%rbeg, lspill_list, ldestructive) - call util_spill(keeps%vbeg, discards%vbeg, lspill_list, ldestructive) - call util_spill(keeps%Ip, discards%Ip, lspill_list, ldestructive) - call util_spill(keeps%rot, discards%rot, lspill_list, ldestructive) - - if (ldestructive .and. allocated(keeps%k_plpl)) deallocate(keeps%k_plpl) - - call util_spill_body(keeps, discards, lspill_list, ldestructive) - class default - write(*,*) 'Error! spill method called for incompatible return type on swiftest_pl' - end select - end associate - - return - end subroutine util_spill_pl - - - module subroutine util_spill_tp(self, discards, lspill_list, ldestructive) - !! author: David A. Minton - !! - !! Move spilled (discarded) Swiftest 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(swiftest_tp), intent(inout) :: self !! Swiftest 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 discardse - logical, intent(in) :: ldestructive !! Logical flag indicating whether or not this operation should alter body by removing the discard list - - associate(keeps => self, ntp => self%nbody) - select type(discards) - class is (swiftest_tp) - !> Spill components specific to the test particle class - 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) - - call util_spill_body(keeps, discards, lspill_list, ldestructive) - class default - write(*,*) 'Error! spill method called for incompatible return type on swiftest_tp' - end select - end associate - - return - end subroutine util_spill_tp - -end submodule s_util_spill \ No newline at end of file diff --git a/src/util/util_unique.f90 b/src/util/util_unique.f90 deleted file mode 100644 index 19eb4ba78..000000000 --- a/src/util/util_unique.f90 +++ /dev/null @@ -1,80 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule (swiftest_classes) s_util_unique - use swiftest -contains - - module subroutine util_unique_DP(input_array, output_array, index_map) - !! author: David A. Minton - !! - !! Takes an input unsorted integer array and returns a new array of sorted, unique values (DP version) - implicit none - ! Arguments - real(DP), dimension(:), intent(in) :: input_array !! Unsorted input array - real(DP), dimension(:), allocatable, intent(out) :: output_array !! Sorted array of unique values - integer(I4B), dimension(:), allocatable, intent(out) :: index_map !! An array of the same size as input_array that such that any for any index i, output_array(index_map(i)) = input_array(i) - ! Internals - real(DP), dimension(:), allocatable :: unique_array - integer(I4B) :: n - real(DP) :: lo, hi - - allocate(unique_array, mold=input_array) - allocate(index_map(size(input_array))) - lo = minval(input_array) - 1 - hi = maxval(input_array) - - n = 0 - do - n = n + 1 - lo = minval(input_array(:), mask=input_array(:) > lo) - unique_array(n) = lo - where(input_array(:) == lo) index_map(:) = n - if (lo >= hi) exit - enddo - allocate(output_array(n), source=unique_array(1:n)) - - return - end subroutine util_unique_DP - - - module subroutine util_unique_I4B(input_array, output_array, index_map) - !! author: David A. Minton - !! - !! Takes an input unsorted integer array and returns a new array of sorted, unique values (I4B version) - implicit none - ! Arguments - integer(I4B), dimension(:), intent(in) :: input_array !! Unsorted input array - integer(I4B), dimension(:), allocatable, intent(out) :: output_array !! Sorted array of unique values - integer(I4B), dimension(:), allocatable, intent(out) :: index_map !! An array of the same size as input_array that such that any for any index i, output_array(index_map(i)) = input_array(i) - ! Internals - integer(I4B), dimension(:), allocatable :: unique_array - integer(I4B) :: n, lo, hi - - allocate(unique_array, mold=input_array) - allocate(index_map, mold=input_array) - lo = minval(input_array) - 1 - hi = maxval(input_array) - - n = 0 - do - n = n + 1 - lo = minval(input_array(:), mask=input_array(:) > lo) - unique_array(n) = lo - where(input_array(:) == lo) index_map(:) = n - if (lo >= hi) exit - enddo - allocate(output_array(n), source=unique_array(1:n)) - - return - end subroutine util_unique_I4B - - - -end submodule s_util_unique \ No newline at end of file diff --git a/src/util/util_valid.f90 b/src/util/util_valid.f90 deleted file mode 100644 index e6a4b6663..000000000 --- a/src/util/util_valid.f90 +++ /dev/null @@ -1,52 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule (swiftest_classes) s_util_valid - use swiftest -contains - - module subroutine util_valid_id_system(self, param) - !! author: David A. Minton - !! - !! Validate massive body and test particle ids - !! Subroutine causes program to exit with error if any ids are not unique - !! - !! Adapted from David E. Kaufmann's Swifter routine: util_valid.f90 - implicit none - ! Arguments - class(swiftest_nbody_system), intent(inout) :: self !! Swiftest nbody system object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - ! Internals - integer(I4B) :: i - integer(I4B), dimension(:), allocatable :: idarr - - associate(cb => self%cb, pl => self%pl, npl => self%pl%nbody, tp => self%tp, ntp => self%tp%nbody) - allocate(idarr(1+npl+ntp)) - idarr(1) = cb%id - do i = 1, npl - idarr(1+i) = pl%id(i) - end do - do i = 1, ntp - idarr(1+npl+i) = tp%id(i) - end do - call util_sort(idarr) - do i = 1, npl + ntp - if (idarr(i) == idarr(i+1)) then - write(*, *) "Swiftest error:" - write(*, *) " more than one body/particle has id = ", idarr(i) - call util_exit(FAILURE) - end if - end do - param%maxid = max(param%maxid, maxval(idarr)) - end associate - - return - end subroutine util_valid_id_system - -end submodule s_util_valid diff --git a/src/util/util_version.f90 b/src/util/util_version.f90 deleted file mode 100644 index f44062e5e..000000000 --- a/src/util/util_version.f90 +++ /dev/null @@ -1,62 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule (swiftest_classes) s_util_version - use swiftest -contains - - module subroutine util_version() - !! author: David A. Minton - !! - !! Print program version information to terminale - !! - !! Adapted from David E. Kaufmann's Swifter routine: util_version.f90 - implicit none - write(*, 200) VERSION_NUMBER -200 format(/, "************* Swiftest: Version ", f3.1, " *************", //, & - "Based off of Swifter:", //, & - "Authors:", //, & - " The Purdue University Swiftest Development team ", /, & - " Lead by David A. Minton ", /, & - " Single loop blocking by Jacob R. Elliott", /, & - " Fragmentation by Carlisle A. Wishard and", //, & - " Jennifer L. L. Poutplin ", //, & - "Please address comments and questions to:", //, & - " David A. Minton", /, & - " Department Earth, Atmospheric, & Planetary Sciences ",/, & - " Purdue University", /, & - " 550 Stadium Mall Drive", /, & - " West Lafayette, Indiana 47907", /, & - " 765-250-8034 ", /, & - " daminton@purdue.edu", /, & - "Special thanks to Hal Levison and Martin Duncan for the original",/,& - "SWIFTER and SWIFT codes that made this possible.", //, & - "************************************************", /) - - - 100 FORMAT(/, "************* SWIFTER: Version ", F3.1, " *************", //, & - "Authors:", //, & - " Martin Duncan: Queen's University", /, & - " Hal Levison : Southwest Research Institute", //, & - "Please address comments and questions to:", //, & - " Hal Levison or David Kaufmann", /, & - " Department of Space Studies", /, & - " Southwest Research Institute", /, & - " 1050 Walnut Street, Suite 400", /, & - " Boulder, Colorado 80302", /, & - " 303-546-0290 (HFL), 720-240-0119 (DEK)", /, & - " 303-546-9687 (fax)", /, & - " hal@gort.boulder.swri.edu (HFL)", /, & - " kaufmann@boulder.swri.edu (DEK)", //, & - "************************************************", /) - - return - end subroutine util_version - -end submodule s_util_version diff --git a/src/walltime/walltime.f90 b/src/walltime/walltime.f90 deleted file mode 100644 index 491a2e478..000000000 --- a/src/walltime/walltime.f90 +++ /dev/null @@ -1,352 +0,0 @@ -!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh -!! This file is part of Swiftest. -!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License -!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. -!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty -!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. -!! You should have received a copy of the GNU General Public License along with Swiftest. -!! If not, see: https://www.gnu.org/licenses. - -submodule(walltime_classes) s_walltime - use swiftest -contains - - module subroutine walltime_stop(self) - !! author: David A. Minton - !! - !! Pauses the step timer (but not the main timer). - implicit none - ! Arguments - class(walltimer), intent(inout) :: self !! Walltimer object - ! Internals - integer(I8B) :: count_delta - - if (self%is_paused) then - write(*,*) "Wall timer error: Timer is already paused!" - return - end if - - call system_clock(self%count_pause) - self%is_paused = .true. - - self%count_stop_step = self%count_pause - - count_delta = self%count_stop_step - self%count_start_step - self%wall_step = count_delta / (self%count_rate * 1.0_DP) - - return - end subroutine walltime_stop - - - module subroutine walltime_report(self, message, unit, nsubsteps) - !! author: David A. Minton - !! - !! Prints the elapsed time information to the terminal - implicit none - ! Arguments - class(walltimer), intent(inout) :: self !! Walltimer object - character(len=*), intent(in) :: message !! Message to prepend to the wall time terminal output - integer(I4B), intent(in) :: unit !! Output file unit for report text to be directed - integer(I4B), optional, intent(in) :: nsubsteps !! Number of substeps used to compute the time per step - ! Internals - character(len=*), parameter :: nosubstepfmt = '" Total wall time: ", es12.5, "; Interval wall time: ", es12.5 ' - character(len=*), parameter :: substepfmt = '" Total wall time: ", es12.5, "; Interval wall time: ", es12.5, ";' //& - 'Interval wall time/step: ", es12.5' - character(len=STRMAX) :: fmt - integer(I8B) :: count_delta_step, count_delta_main, count_now - - if (.not.self%main_is_started) then - write(*,*) "Wall timer error: The step finish time cannot be calculated because the timer is not started!" - return - end if - - call system_clock(count_now) - count_delta_main = count_now - self%count_start_main - count_delta_step = count_now - self%count_start_step - self%wall_main = count_delta_main / (self%count_rate * 1.0_DP) - self%wall_step = count_delta_step / (self%count_rate * 1.0_DP) - if (present(nsubsteps)) then - self%wall_per_substep = self%wall_step / nsubsteps - fmt = '("' // adjustl(message) // '",' // substepfmt // ')' - write(unit,trim(adjustl(fmt))) self%wall_main, self%wall_step, self%wall_per_substep - else - fmt = '("' // adjustl(message) // '",' // nosubstepfmt // ')' - write(unit,trim(adjustl(fmt))) self%wall_main, self%wall_step - end if - - return - end subroutine walltime_report - - - module subroutine walltime_reset(self) - !! author: David A. Minton - !! - !! Resets the step timer - implicit none - ! Arguments - class(walltimer), intent(inout) :: self !! Walltimer object - ! Internals - - self%is_paused = .false. - self%wall_step = 0.0_DP - self%wall_per_substep = 0.0_DP - - return - end subroutine walltime_reset - - - module subroutine walltime_start_main(self) - !! author: David A. Minton - !! - !! Resets the clock ticker, settting main_start to the current ticker value - implicit none - ! Arguments - class(walltimer), intent(inout) :: self !! Walltimer object - - call system_clock(self%count_start_main, self%count_rate, self%count_max) - self%main_is_started = .true. - self%wall_main = 0.0_DP - - return - end subroutine walltime_start_main - - - module subroutine walltime_start(self) - !! author: David A. Minton - !! - !! Starts or resumes the step timer - !! - implicit none - ! Arguments - class(walltimer), intent(inout) :: self !! Walltimer object - ! Internals - integer(I8B) :: count_resume, count_delta - - if (.not.self%main_is_started) then - call self%reset() - call self%start_main() - end if - - if (self%is_paused) then ! Resume a paused step timer - call system_clock(count_resume) - count_delta = count_resume - self%count_pause - self%count_pause = 0_I8B - self%count_start_step = self%count_start_step + count_delta - self%is_paused = .false. - else ! Start a new step timer - call system_clock(self%count_start_step) - end if - - return - end subroutine walltime_start - - - module subroutine walltime_interaction_adapt(self, param, ninteractions, pl) - !! author: David A. Minton - !! - !! Determines which of the two loop styles is fastest and keeps that one - implicit none - ! Arguments - class(interaction_timer), intent(inout) :: self !! Walltimer object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - integer(I8B), intent(in) :: ninteractions !! Current number of interactions (used to normalize the timed loop and to determine if number of interactions has changed since the last timing - class(swiftest_pl), intent(inout), optional :: pl !! Swiftest massive body object - ! Internals - character(len=STRMAX) :: nstr, cstr, mstr - character(len=11) :: lstyle, advancedstyle, standardstyle - character(len=1) :: schar - logical :: ladvanced_final - character(len=NAMELEN) :: logfile - - ! Record the elapsed time - call self%stop() - - select case(trim(adjustl(self%looptype))) - case("INTERACTION") - write(advancedstyle, *) "FLAT " - write(standardstyle, *) "TRIANGULAR" - write(logfile,*) INTERACTION_TIMER_LOG_OUT - case("ENCOUNTER_PLPL") - write(advancedstyle, *) "SORTSWEEP " - write(standardstyle, *) "TRIANGULAR" - write(logfile,*) ENCOUNTER_PLPL_TIMER_LOG_OUT - case("ENCOUNTER_PLTP") - write(advancedstyle, *) "SORTSWEEP " - write(standardstyle, *) "TRIANGULAR" - write(logfile,*) ENCOUNTER_PLTP_TIMER_LOG_OUT - case default - write(logfile,*) "unknown_looptimer.log" - end select - - write(schar,'(I1)') self%stage - write(nstr,*) ninteractions - - select case(self%stage) - case(1) - if (self%stage1_is_advanced) then - lstyle = advancedstyle - else - lstyle = standardstyle - end if - self%stage1_metric = (self%count_stop_step - self%count_start_step) / real(ninteractions, kind=DP) - write(mstr,*) self%stage1_metric - case(2) - if (.not.self%stage1_is_advanced) then - lstyle = advancedstyle - else - lstyle = standardstyle - end if - - self%stage2_metric = (self%count_stop_step - self%count_start_step) / real(ninteractions, kind=DP) - self%is_on = .false. - self%step_counter = 0 - if (self%stage1_metric < self%stage2_metric) then - ladvanced_final = self%stage1_is_advanced - call self%flip(param, pl) ! Go back to the original style, otherwise keep the stage2 style - else - ladvanced_final = .not.self%stage1_is_advanced - end if - write(mstr,*) self%stage2_metric - end select - - write(cstr,*) self%count_stop_step - self%count_start_step - - call io_log_one_message(logfile, adjustl(lstyle) // " " // trim(adjustl(cstr)) // " " // & - trim(adjustl(nstr)) // " " // trim(adjustl(mstr))) - - if (self%stage == 2) then - if (ladvanced_final) then - lstyle = advancedstyle - else - lstyle = standardstyle - end if - call io_log_one_message(logfile, trim(adjustl(self%loopname)) // & - ": the fastest loop method tested is " // trim(adjustl(lstyle))) - end if - - return - end subroutine walltime_interaction_adapt - - - module function walltime_interaction_check(self, param, ninteractions) result(ltimeit) - !! author: David A. Minton - !! - !! Checks whether or not the loop should be timed and starts the timer if the conditions for starting are met - implicit none - ! Arguments - class(interaction_timer), intent(inout) :: self !! Walltimer object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - integer(I8B), intent(in) :: ninteractions !! Current number of interactions (used to normalize the timed loop and to determine if number of interactions has changed since the last timing - logical :: ltimeit !! Logical flag indicating whether this loop should be timed or not - - if (self%is_on) then ! Entering the second stage of the loop timing. Therefore we will swap the interaction style and time this loop - self%stage = self%stage + 1 - ltimeit = (self%stage == 2) - else - self%step_counter = min(self%step_counter + 1, INTERACTION_TIMER_CADENCE) - ltimeit = .false. - if (self%step_counter == INTERACTION_TIMER_CADENCE) then - ltimeit = (ninteractions /= self%last_interactions) - if (ltimeit) self%stage = 1 - end if - end if - self%is_on = ltimeit - - return - end function walltime_interaction_check - - - module subroutine walltime_interaction_flip_loop_style(self, param, pl) - !! author: David A. Minton - !! - !! Flips the interaction loop style from FLAT to TRIANGULAR or vice versa - implicit none - ! Arguments - class(interaction_timer), intent(inout) :: self !! Interaction loop timer object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - class(swiftest_pl), intent(inout), optional :: pl !! Swiftest massive body object - - select case(trim(adjustl(self%looptype))) - case("INTERACTION") - param%lflatten_interactions = .not. param%lflatten_interactions - case("ENCOUNTER_PLPL") - param%lencounter_sas_plpl= .not. param%lencounter_sas_plpl - case("ENCOUNTER_PLTP") - param%lencounter_sas_pltp= .not. param%lencounter_sas_pltp - end select - - if (present(pl)) then - if (param%lflatten_interactions) then - call pl%flatten(param) - else - if (allocated(pl%k_plpl)) deallocate(pl%k_plpl) - end if - end if - - return - end subroutine walltime_interaction_flip_loop_style - - - module subroutine walltime_interaction_time_this_loop(self, param, ninteractions, pl) - !! author: David A. Minton - !! - !! Resets the interaction loop timer, and saves the current value of the array flatten parameter - implicit none - ! Arguments - class(interaction_timer), intent(inout) :: self !! Interaction loop timer object - class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters - integer(I8B), intent(in) :: ninteractions !! Current number of interactions (used to normalize the timed loop) - class(swiftest_pl), intent(inout), optional :: pl !! Swiftest massive body object - ! Internals - character(len=STRMAX) :: tstr - character(len=1) :: schar - character(len=NAMELEN) :: logfile - - select case(trim(adjustl(self%looptype))) - case("INTERACTION") - write(logfile,*) INTERACTION_TIMER_LOG_OUT - case("ENCOUNTER_PLPL") - write(logfile,*) ENCOUNTER_PLPL_TIMER_LOG_OUT - case("ENCOUNTER_PLTP") - write(logfile,*) ENCOUNTER_PLTP_TIMER_LOG_OUT - case default - write(logfile,*) "unknown_looptimer.log" - end select - - self%is_on = .true. - select case(self%stage) - case(1) - self%stage1_ninteractions = ninteractions - select case(trim(adjustl(self%looptype))) - case("INTERACTION") - self%stage1_is_advanced = param%lflatten_interactions - case("ENCOUNTER_PLPL") - self%stage1_is_advanced = param%lencounter_sas_plpl - case("ENCOUNTER_PLTP") - self%stage1_is_advanced = param%lencounter_sas_pltp - end select - call io_log_one_message(logfile, trim(adjustl(self%loopname)) // ": loop timer turned on at t = " // trim(adjustl(tstr))) - case(2) - select case(trim(adjustl(self%looptype))) - case("INTERACTION") - param%lflatten_interactions = self%stage1_is_advanced - case("ENCOUNTER_PLPL") - param%lencounter_sas_plpl= self%stage1_is_advanced - case("ENCOUNTER_PLTP") - param%lencounter_sas_pltp= self%stage1_is_advanced - end select - call self%flip(param, pl) - case default - self%stage = 1 - end select - - write(schar,'(I1)') self%stage - call io_log_one_message(logfile, trim(adjustl(self%loopname)) // ": stage " // schar ) - - call self%reset() - call self%start() - - return - end subroutine walltime_interaction_time_this_loop - -end submodule s_walltime \ No newline at end of file diff --git a/src/walltime/walltime_implementations.f90 b/src/walltime/walltime_implementations.f90 new file mode 100644 index 000000000..c0804b664 --- /dev/null +++ b/src/walltime/walltime_implementations.f90 @@ -0,0 +1,143 @@ +!! Copyright 2022 - David Minton, Carlisle Wishard, Jennifer Pouplin, Jake Elliott, & Dana Singh +!! This file is part of Swiftest. +!! Swiftest is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License +!! as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. +!! Swiftest is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty +!! of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. +!! You should have received a copy of the GNU General Public License along with Swiftest. +!! If not, see: https://www.gnu.org/licenses. + +submodule(walltime) s_walltime + use swiftest +contains + + module subroutine walltime_stop(self) + !! author: David A. Minton + !! + !! Pauses the step timer (but not the main timer). + implicit none + ! Arguments + class(walltimer), intent(inout) :: self !! Walltimer object + ! Internals + integer(I8B) :: count_delta + + if (self%is_paused) then + write(*,*) "Wall timer error: Timer is already paused!" + return + end if + + call system_clock(self%count_pause) + self%is_paused = .true. + + self%count_stop_step = self%count_pause + + count_delta = self%count_stop_step - self%count_start_step + self%wall_step = count_delta / (self%count_rate * 1.0_DP) + + return + end subroutine walltime_stop + + + module subroutine walltime_report(self, message, unit, nsubsteps) + !! author: David A. Minton + !! + !! Prints the elapsed time information to the terminal + implicit none + ! Arguments + class(walltimer), intent(inout) :: self !! Walltimer object + character(len=*), intent(in) :: message !! Message to prepend to the wall time terminal output + integer(I4B), intent(in) :: unit !! Output file unit for report text to be directed + integer(I4B), optional, intent(in) :: nsubsteps !! Number of substeps used to compute the time per step + ! Internals + character(len=*), parameter :: nosubstepfmt = '" Total wall time: ", es12.5, "; Interval wall time: ", es12.5 ' + character(len=*), parameter :: substepfmt = '" Total wall time: ", es12.5, "; Interval wall time: ", es12.5, ";' //& + 'Interval wall time/step: ", es12.5' + character(len=STRMAX) :: fmt + integer(I8B) :: count_delta_step, count_delta_main, count_now + + if (.not.self%main_is_started) then + write(*,*) "Wall timer error: The step finish time cannot be calculated because the timer is not started!" + return + end if + + call system_clock(count_now) + count_delta_main = count_now - self%count_start_main + count_delta_step = count_now - self%count_start_step + self%wall_main = count_delta_main / (self%count_rate * 1.0_DP) + self%wall_step = count_delta_step / (self%count_rate * 1.0_DP) + if (present(nsubsteps)) then + self%wall_per_substep = self%wall_step / nsubsteps + fmt = '("' // adjustl(message) // '",' // substepfmt // ')' + write(unit,trim(adjustl(fmt))) self%wall_main, self%wall_step, self%wall_per_substep + else + fmt = '("' // adjustl(message) // '",' // nosubstepfmt // ')' + write(unit,trim(adjustl(fmt))) self%wall_main, self%wall_step + end if + + return + end subroutine walltime_report + + + module subroutine walltime_reset(self) + !! author: David A. Minton + !! + !! Resets the step timer + implicit none + ! Arguments + class(walltimer), intent(inout) :: self !! Walltimer object + ! Internals + + self%is_paused = .false. + self%wall_step = 0.0_DP + self%wall_per_substep = 0.0_DP + + return + end subroutine walltime_reset + + + module subroutine walltime_start_main(self) + !! author: David A. Minton + !! + !! Resets the clock ticker, settting main_start to the current ticker value + implicit none + ! Arguments + class(walltimer), intent(inout) :: self !! Walltimer object + + call system_clock(self%count_start_main, self%count_rate, self%count_max) + self%main_is_started = .true. + self%wall_main = 0.0_DP + + return + end subroutine walltime_start_main + + + module subroutine walltime_start(self) + !! author: David A. Minton + !! + !! Starts or resumes the step timer + !! + implicit none + ! Arguments + class(walltimer), intent(inout) :: self !! Walltimer object + ! Internals + integer(I8B) :: count_resume, count_delta + + if (.not.self%main_is_started) then + call self%reset() + call self%start_main() + end if + + if (self%is_paused) then ! Resume a paused step timer + call system_clock(count_resume) + count_delta = count_resume - self%count_pause + self%count_pause = 0_I8B + self%count_start_step = self%count_start_step + count_delta + self%is_paused = .false. + else ! Start a new step timer + call system_clock(self%count_start_step) + end if + + return + end subroutine walltime_start + +end submodule s_walltime \ No newline at end of file diff --git a/src/whm/whm_coord.f90 b/src/whm/whm_coord.f90 index 4af8b56a9..5ecfeedcc 100644 --- a/src/whm/whm_coord.f90 +++ b/src/whm/whm_coord.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule (whm_classes) s_whm_coord +submodule (whm) s_whm_coord use swiftest contains diff --git a/src/whm/whm_drift.f90 b/src/whm/whm_drift.f90 index 4efefe2b5..31d041505 100644 --- a/src/whm/whm_drift.f90 +++ b/src/whm/whm_drift.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(whm_classes) whm_drift +submodule(whm) whm_drift use swiftest contains @@ -33,7 +33,7 @@ module subroutine whm_drift_pl(self, system, param, dt) associate(pl => self, npl => self%nbody) allocate(iflag(npl)) iflag(:) = 0 - call drift_all(pl%muj, pl%xj, pl%vj, npl, param, dt, pl%lmask, iflag) + call swiftest_drift_all(pl%muj, pl%xj, pl%vj, npl, param, dt, pl%lmask, iflag) if (any(iflag(1:npl) /= 0)) then where(iflag(1:npl) /= 0) pl%status(1:npl) = DISCARDED_DRIFTERR diff --git a/src/whm/whm_gr.f90 b/src/whm/whm_gr.f90 index 01bd6f285..dc694a168 100644 --- a/src/whm/whm_gr.f90 +++ b/src/whm/whm_gr.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(whm_classes) s_whm_gr +submodule(whm) s_whm_gr use swiftest contains @@ -31,7 +31,7 @@ pure module subroutine whm_gr_kick_getacch_pl(self, param) if (self%nbody == 0) return associate(pl => self, npl => self%nbody, inv_c2 => param%inv_c2) - call gr_kick_getacch(pl%muj, pl%xj, pl%lmask, npl, param%inv_c2, pl%agr) + call swiftest_gr_kick_getacch(pl%muj, pl%xj, pl%lmask, npl, param%inv_c2, pl%agr) suma(:) = 0.0_DP pl%ah(:, 1) = pl%ah(:, 1) + pl%agr(:, 1) do i = 2, npl @@ -62,7 +62,7 @@ pure module subroutine whm_gr_kick_getacch_tp(self, param) if (self%nbody == 0) return associate(tp => self, ntp => self%nbody, inv_c2 => param%inv_c2) - call gr_kick_getacch(tp%mu, tp%rh, tp%lmask, ntp, param%inv_c2, tp%agr) + call swiftest_gr_kick_getacch(tp%mu, tp%rh, tp%lmask, ntp, param%inv_c2, tp%agr) tp%ah(:,1:ntp) = tp%ah(:,1:ntp) + tp%agr(:,1:ntp) end associate @@ -89,7 +89,7 @@ pure module subroutine whm_gr_p4_pl(self, system, param, dt) associate(pl => self, npl => self%nbody) if (npl == 0) return do concurrent(i = 1:npl, pl%lmask(i)) - call gr_p4_pos_kick(param, pl%xj(:, i), pl%vj(:, i), dt) + call swiftest_gr_p4_pos_kick(param, pl%xj(:, i), pl%vj(:, i), dt) end do end associate @@ -116,7 +116,7 @@ pure module subroutine whm_gr_p4_tp(self, system, param, dt) associate(tp => self, ntp => self%nbody) if (ntp == 0) return do concurrent(i = 1:ntp, tp%lmask(i)) - call gr_p4_pos_kick(param, tp%rh(:, i), tp%vh(:, i), dt) + call swiftest_gr_p4_pos_kick(param, tp%rh(:, i), tp%vh(:, i), dt) end do end associate diff --git a/src/whm/whm_kick.f90 b/src/whm/whm_kick.f90 index b675e4370..0b0746b87 100644 --- a/src/whm/whm_kick.f90 +++ b/src/whm/whm_kick.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(whm_classes) s_whm_kick +submodule(whm) s_whm_kick use swiftest contains @@ -96,11 +96,11 @@ module subroutine whm_kick_getacch_tp(self, system, param, t, lbeg) end do call tp%accel_int(param, pl%Gmass(1:npl), pl%rbeg(:, 1:npl), npl) else - ah0(:) = whm_kick_getacch_ah0(pl%Gmass(1:npl), pl%xend(:, 1:npl), npl) + ah0(:) = whm_kick_getacch_ah0(pl%Gmass(1:npl), pl%rend(:, 1:npl), npl) do concurrent(i = 1:ntp, tp%lmask(i)) tp%ah(:, i) = tp%ah(:, i) + ah0(:) end do - call tp%accel_int(param, pl%Gmass(1:npl), pl%xend(:, 1:npl), npl) + call tp%accel_int(param, pl%Gmass(1:npl), pl%rend(:, 1:npl), npl) end if if (param%loblatecb) call tp%accel_obl(system) @@ -231,7 +231,7 @@ module subroutine whm_kick_vh_pl(self, system, param, t, dt, lbeg) else pl%ah(:, 1:npl) = 0.0_DP call pl%accel(system, param, t, lbeg) - call pl%set_beg_end(xend = pl%rh) + call pl%set_beg_end(rend = pl%rh) end if do concurrent(i = 1:npl, pl%lmask(i)) pl%vh(:, i) = pl%vh(:, i) + pl%ah(:, i) * dt diff --git a/src/whm/whm_setup.f90 b/src/whm/whm_setup.f90 index a9755d0d4..ae54fa9e8 100644 --- a/src/whm/whm_setup.f90 +++ b/src/whm/whm_setup.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(whm_classes) s_whm_setup +submodule(whm) s_whm_setup use swiftest contains diff --git a/src/whm/whm_step.f90 b/src/whm/whm_step.f90 index 9f6b9bea1..f592bdf66 100644 --- a/src/whm/whm_step.f90 +++ b/src/whm/whm_step.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(whm_classes) s_whm_step +submodule(whm) s_whm_step use swiftest contains diff --git a/src/whm/whm_util.f90 b/src/whm/whm_util.f90 index c58f5730f..f6a16a44c 100644 --- a/src/whm/whm_util.f90 +++ b/src/whm/whm_util.f90 @@ -7,7 +7,7 @@ !! You should have received a copy of the GNU General Public License along with Swiftest. !! If not, see: https://www.gnu.org/licenses. -submodule(whm_classes) s_whm_util +submodule(whm) s_whm_util use swiftest contains