From 20865a6dc92a45353a6a05ca0a74be5281338999 Mon Sep 17 00:00:00 2001 From: David Minton Date: Tue, 6 Jun 2023 15:35:08 -0400 Subject: [PATCH] Removed do concurrents from operators and switched to manual cross product when in a do concurrent --- src/collision/collision_util.f90 | 62 +++++++++----- src/encounter/encounter_check.f90 | 10 +-- src/fraggle/fraggle_generate.f90 | 130 ++++++++++++++++++++---------- src/operator/operator_cross.f90 | 42 ++-------- src/operator/operator_mag.f90 | 18 +---- src/operator/operator_unit.f90 | 18 +---- 6 files changed, 147 insertions(+), 133 deletions(-) diff --git a/src/collision/collision_util.f90 b/src/collision/collision_util.f90 index 179fb289c..75c836b4c 100644 --- a/src/collision/collision_util.f90 +++ b/src/collision/collision_util.f90 @@ -146,13 +146,15 @@ end subroutine collision_util_get_idvalues_snapshot module subroutine collision_util_get_energy_and_momentum(self, nbody_system, param, phase) !! Author: David A. Minton !! - !! Calculates total system energy in either the pre-collision outcome state (phase = "before") or the post-collision outcome state (lbefore = .false.) + !! Calculates total system energy in either the pre-collision outcome state (phase = "before") or the post-collision outcome + !! state (lbefore = .false.) implicit none ! Arguments class(collision_basic), intent(inout) :: self !! Encounter collision system object class(base_nbody_system), intent(inout) :: nbody_system !! Swiftest nbody system object class(base_parameters), intent(inout) :: param !! Current Swiftest run configuration parameters - character(len=*), intent(in) :: phase !! One of "before" or "after", indicating which phase of the calculation this needs to be done + character(len=*), intent(in) :: phase !! One of "before" or "after", indicating which phase of the + !! calculation this needs to be done ! Internals integer(I4B) :: i, phase_val, nfrag @@ -179,9 +181,15 @@ module subroutine collision_util_get_energy_and_momentum(self, nbody_system, par do concurrent(i = 1:2) #endif impactors%ke_orbit(i) = 0.5_DP * impactors%mass(i) * dot_product(impactors%vc(:,i), impactors%vc(:,i)) - impactors%ke_spin(i) = 0.5_DP * impactors%mass(i) * impactors%radius(i)**2 * impactors%Ip(3,i) * dot_product(impactors%rot(:,i), impactors%rot(:,i)) + impactors%ke_spin(i) = 0.5_DP * impactors%mass(i) * impactors%radius(i)**2 * impactors%Ip(3,i) & + * dot_product(impactors%rot(:,i), impactors%rot(:,i)) impactors%be(i) = -3 * impactors%Gmass(i) * impactors%mass(i) / (5 * impactors%radius(i)) - impactors%L_orbit(:,i) = impactors%mass(i) * impactors%rc(:,i) .cross. impactors%vc(:,i) + impactors%L_orbit(1,i) = impactors%mass(i) * (impactors%rc(2,i) * impactors%vc(3,i) & + - impactors%rc(3,i) * impactors%vc(2,i)) + impactors%L_orbit(2,i) = impactors%mass(i) * (impactors%rc(3,i) * impactors%vc(1,i) & + - impactors%rc(1,i) * impactors%vc(3,i)) + impactors%L_orbit(3,i) = impactors%mass(i) * (impactors%rc(1,i) * impactors%vc(2,i) & + - impactors%rc(2,i) * impactors%vc(1,i)) impactors%L_spin(:,i) = impactors%mass(i) * impactors%radius(i)**2 * impactors%Ip(3,i) * impactors%rot(:,i) end do self%L_orbit(:,phase_val) = sum(impactors%L_orbit(:,1:2),dim=2) @@ -190,7 +198,8 @@ module subroutine collision_util_get_energy_and_momentum(self, nbody_system, par self%ke_orbit(phase_val) = sum(impactors%ke_orbit(1:2)) self%ke_spin(phase_val) = sum(impactors%ke_spin(1:2)) self%be(phase_val) = sum(impactors%be(1:2)) - call swiftest_util_get_potential_energy(2, [(.true., i = 1, 2)], 0.0_DP, impactors%Gmass, impactors%mass, impactors%rb, self%pe(phase_val)) + call swiftest_util_get_potential_energy(2, [(.true., i = 1, 2)], 0.0_DP, impactors%Gmass, impactors%mass, & + impactors%rb, self%pe(phase_val)) self%te(phase_val) = self%ke_orbit(phase_val) + self%ke_spin(phase_val) + self%be(phase_val) + self%pe(phase_val) else if (phase_val == 2) then #ifdef DOCONLOC @@ -199,11 +208,18 @@ module subroutine collision_util_get_energy_and_momentum(self, nbody_system, par do concurrent(i = 1:nfrag) #endif fragments%ke_orbit(i) = 0.5_DP * fragments%mass(i) * dot_product(fragments%vc(:,i), fragments%vc(:,i)) - fragments%ke_spin(i) = 0.5_DP * fragments%mass(i) * fragments%radius(i)**2 * fragments%Ip(3,i) * dot_product(fragments%rot(:,i), fragments%rot(:,i)) - fragments%L_orbit(:,i) = fragments%mass(i) * fragments%rc(:,i) .cross. fragments%vc(:,i) + fragments%ke_spin(i) = 0.5_DP * fragments%mass(i) * fragments%radius(i)**2 * fragments%Ip(3,i) & + * dot_product(fragments%rot(:,i), fragments%rot(:,i)) + fragments%L_orbit(1,i) = fragments%mass(i) * (fragments%rc(2,i) * fragments%vc(3,i) - & + fragments%rc(3,i) * fragments%vc(2,i)) + fragments%L_orbit(2,i) = fragments%mass(i) * (fragments%rc(3,i) * fragments%vc(1,i) - & + fragments%rc(1,i) * fragments%vc(3,i)) + fragments%L_orbit(3,i) = fragments%mass(i) * (fragments%rc(1,i) * fragments%vc(2,i) - & + fragments%rc(2,i) * fragments%vc(1,i)) fragments%L_spin(:,i) = fragments%mass(i) * fragments%radius(i)**2 * fragments%Ip(3,i) * fragments%rot(:,i) end do - call swiftest_util_get_potential_energy(nfrag, [(.true., i = 1, nfrag)], 0.0_DP, fragments%Gmass, fragments%mass, fragments%rb, fragments%pe) + call swiftest_util_get_potential_energy(nfrag, [(.true., i = 1, nfrag)], 0.0_DP, fragments%Gmass, fragments%mass, & + fragments%rb, fragments%pe) fragments%be = sum(-3*fragments%Gmass(1:nfrag)*fragments%mass(1:nfrag)/(5*fragments%radius(1:nfrag))) fragments%L_orbit_tot(:) = sum(fragments%L_orbit(:,1:nfrag),dim=2) fragments%L_spin_tot(:) = sum(fragments%L_spin(:,1:nfrag),dim=2) @@ -541,9 +557,11 @@ end subroutine collision_util_setup_fragments module subroutine collision_util_set_coordinate_collider(self) - + !! author: David A. Minton + !! !! - !! Defines the collisional coordinate nbody_system, including the unit vectors of both the nbody_system and individual fragments. + !! Defines the collisional coordinate nbody_system, including the unit vectors of both the nbody_system and individual + !! fragments. implicit none ! Arguments class(collision_basic), intent(inout) :: self !! Collisional nbody_system @@ -564,7 +582,8 @@ end subroutine collision_util_set_coordinate_collider module subroutine collision_util_set_coordinate_fragments(self) !! author: David A. Minton !! - !! Defines the collisional coordinate nbody_system, including the unit vectors of both the nbody_system and individual fragments. + !! Defines the collisional coordinate nbody_system, including the unit vectors of both the nbody_system and individual + !! fragments. implicit none ! Arguments class(collision_fragments), intent(inout) :: self !! Collisional nbody_system @@ -590,7 +609,8 @@ end subroutine collision_util_set_coordinate_fragments module subroutine collision_util_set_coordinate_impactors(self) !! author: David A. Minton !! - !! Defines the collisional coordinate nbody_system, including the unit vectors of both the nbody_system and individual fragments. + !! Defines the collisional coordinate nbody_system, including the unit vectors of both the nbody_system and individual + !! fragments. implicit none ! Arguments class(collision_impactors), intent(inout) :: self !! Collisional nbody_system @@ -602,8 +622,8 @@ module subroutine collision_util_set_coordinate_impactors(self) delta_v(:) = impactors%vb(:, 2) - impactors%vb(:, 1) delta_r(:) = impactors%rb(:, 2) - impactors%rb(:, 1) - ! We will initialize fragments on a plane defined by the pre-impact nbody_system, with the z-axis aligned with the angular momentum vector - ! and the y-axis aligned with the pre-impact distance vector. + ! We will initialize fragments on a plane defined by the pre-impact nbody_system, with the z-axis aligned with the angular + ! momentum vector and the y-axis aligned with the pre-impact distance vector. ! y-axis is the separation distance impactors%y_unit(:) = .unit.delta_r(:) @@ -632,14 +652,16 @@ module subroutine collision_util_set_coordinate_impactors(self) impactors%vc(:,1) = impactors%vb(:,1) - impactors%vbcom(:) impactors%vc(:,2) = impactors%vb(:,2) - impactors%vbcom(:) - ! Find the point of impact between the two bodies, defined as the location (in the collisional coordinate system) at the surface of body 1 along the line connecting the two bodies. + ! Find the point of impact between the two bodies, defined as the location (in the collisional coordinate system) at the + ! surface of body 1 along the line connecting the two bodies. impactors%rcimp(:) = impactors%rb(:,1) + impactors%radius(1) * impactors%y_unit(:) - impactors%rbcom(:) ! Set the velocity direction as the "bounce" direction" for disruptions, and body 2's direction for hit and runs if (impactors%regime == COLLRESOLVE_REGIME_HIT_AND_RUN) then impactors%bounce_unit(:) = .unit. impactors%vc(:,2) else - impactors%bounce_unit(:) = .unit. (impactors%vc(:,2) - 2 * dot_product(impactors%vc(:,2),impactors%y_unit(:)) * impactors%y_unit(:)) + impactors%bounce_unit(:) = .unit. (impactors%vc(:,2) - 2 * dot_product(impactors%vc(:,2),impactors%y_unit(:)) & + * impactors%y_unit(:)) end if end associate @@ -742,7 +764,8 @@ module subroutine collision_util_snapshot(self, param, nbody_system, t, arg) class(base_parameters), intent(inout) :: param !! Current run configuration parameters class(base_nbody_system), intent(inout) :: nbody_system !! Swiftest nbody system object to store real(DP), intent(in), optional :: t !! Time of snapshot if different from nbody_system time - character(*), intent(in), optional :: arg !! "before": takes a snapshot just before the collision. "after" takes the snapshot just after the collision. + 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, save :: snapshot character(len=:), allocatable :: stage @@ -816,8 +839,9 @@ module subroutine collision_util_snapshot(self, param, nbody_system, t, arg) write(message,*) trim(adjustl(plnew%info(i)%name)), " (", trim(adjustl(plnew%info(i)%particle_type)),")" call swiftest_io_log_one_message(COLLISION_LOG_OUT, message) end do - call swiftest_io_log_one_message(COLLISION_LOG_OUT, "***********************************************************" // & - "***********************************************************") + call swiftest_io_log_one_message(COLLISION_LOG_OUT, & + "***********************************************************" // & + "***********************************************************") allocate(after_snap%pl, source=plnew) end select deallocate(after_orig%pl) diff --git a/src/encounter/encounter_check.f90 b/src/encounter/encounter_check.f90 index 2d934e7d8..deef9bdda 100644 --- a/src/encounter/encounter_check.f90 +++ b/src/encounter/encounter_check.f90 @@ -179,7 +179,7 @@ subroutine encounter_check_all_sort_and_sweep_plpl(npl, r, v, renc, dt, nenc, in #else do concurrent (i = 1:npl) #endif - rmag = .mag.r(:,i) + rmag = norm2(r(:,i)) rmax(i) = rmag + RSWEEP_FACTOR * renc(i) rmin(i) = rmag - RSWEEP_FACTOR * renc(i) end do @@ -236,7 +236,7 @@ subroutine encounter_check_all_sort_and_sweep_plplm(nplm, nplt, rplm, vplm, rplt #else do concurrent (i = 1:nplm) #endif - rmag = .mag.rplm(:,i) + rmag = norm2(rplm(:,i)) rmax(i) = rmag + RSWEEP_FACTOR * rencm(i) rmin(i) = rmag - RSWEEP_FACTOR * rencm(i) end do @@ -245,7 +245,7 @@ subroutine encounter_check_all_sort_and_sweep_plplm(nplm, nplt, rplm, vplm, rplt #else do concurrent (i = 1:nplt) #endif - rmag = .mag.rplt(:,i) + rmag = norm2(rplt(:,i)) rmax(nplm+i) = rmag + RSWEEP_FACTOR * renct(i) rmin(nplm+i) = rmag - RSWEEP_FACTOR * renct(i) end do @@ -304,7 +304,7 @@ subroutine encounter_check_all_sort_and_sweep_pltp(npl, ntp, rpl, vpl, rtp, vtp, #else do concurrent (i = 1:npl) #endif - rmag = .mag.rpl(:,i) + rmag = norm2(rpl(:,i)) rmax(i) = rmag + RSWEEP_FACTOR * rencpl(i) rmin(i) = rmag - RSWEEP_FACTOR * rencpl(i) end do @@ -313,7 +313,7 @@ subroutine encounter_check_all_sort_and_sweep_pltp(npl, ntp, rpl, vpl, rtp, vtp, #else do concurrent (i = 1:ntp) #endif - rmag = .mag.rtp(:,i) + rmag = norm2(rtp(:,i)) rmax(npl+i) = rmag + RSWEEP_FACTOR * renctp(i) rmin(npl+i) = rmag - RSWEEP_FACTOR * renctp(i) end do diff --git a/src/fraggle/fraggle_generate.f90 b/src/fraggle/fraggle_generate.f90 index 5ec993fba..cd1df7033 100644 --- a/src/fraggle/fraggle_generate.f90 +++ b/src/fraggle/fraggle_generate.f90 @@ -59,7 +59,8 @@ module subroutine fraggle_generate(self, nbody_system, param, t) call self%set_mass_dist(param) call self%disrupt(nbody_system, param, t, lfailure) if (lfailure) then - call swiftest_io_log_one_message(COLLISION_LOG_OUT, "Fraggle failed to find a solution to match energy contraint. Treating this as a merge.") + call swiftest_io_log_one_message(COLLISION_LOG_OUT, & + "Fraggle failed to find a solution to match energy contraint. Treating this as a merge.") call self%merge(nbody_system, param, t) ! Use the default collision model, which is merge return end if @@ -131,8 +132,9 @@ module subroutine fraggle_generate_disrupt(self, nbody_system, param, t, lfailur real(DP), parameter :: fail_scale_initial = 1.0003_DP integer(I4B) :: nfrag_start - ! The minimization and linear solvers can sometimes lead to floating point exceptions. Rather than halting the code entirely if this occurs, we - ! can simply fail the attempt and try again. So we need to turn off any floating point exception halting modes temporarily + ! The minimization and linear solvers can sometimes lead to floating point exceptions. Rather than halting the code entirely + ! if this occurs, we can simply fail the attempt and try again. So we need to turn off any floating point exception halting + ! modes temporarily call ieee_get_halting_mode(IEEE_ALL,fpe_halting_modes) ! Save the current halting modes so we can turn them off temporarily fpe_quiet_modes(:) = .false. call ieee_set_halting_mode(IEEE_ALL,fpe_quiet_modes) @@ -168,7 +170,8 @@ module subroutine fraggle_generate_disrupt(self, nbody_system, param, t, lfailur if (.not.lfailure) then if (self%fragments%nbody /= nfrag_start) then write(message,*) self%fragments%nbody - call swiftest_io_log_one_message(COLLISION_LOG_OUT, "Fraggle found a solution with " // trim(adjustl(message)) // " fragments" ) + call swiftest_io_log_one_message(COLLISION_LOG_OUT, "Fraggle found a solution with " // trim(adjustl(message)) & + // " fragments" ) end if call self%get_energy_and_momentum(nbody_system, param, phase="after") @@ -176,7 +179,8 @@ module subroutine fraggle_generate_disrupt(self, nbody_system, param, t, lfailur dE = self%te(2) - self%te(1) call swiftest_io_log_one_message(COLLISION_LOG_OUT, "All quantities in collision system natural units") - call swiftest_io_log_one_message(COLLISION_LOG_OUT, "* Conversion factors (collision system units / nbody system units):") + call swiftest_io_log_one_message(COLLISION_LOG_OUT, & + "* Conversion factors (collision system units / nbody system units):") write(message,*) "* Mass: ", self%mscale call swiftest_io_log_one_message(COLLISION_LOG_OUT, message) write(message,*) "* Distance: ", self%dscale @@ -200,7 +204,8 @@ module subroutine fraggle_generate_disrupt(self, nbody_system, param, t, lfailur end if call self%set_original_scale() - self%max_rot = MAX_ROT_SI * param%TU2S ! Re-compute the spin limit from scratch so it doesn't drift due to floating point errors every time we convert + self%max_rot = MAX_ROT_SI * param%TU2S ! Re-compute the spin limit from scratch so it doesn't drift due to floating point + ! errors every time we convert ! Restore the big array if (lk_plpl) call pl%flatten(param) @@ -248,7 +253,8 @@ module subroutine fraggle_generate_hitandrun(self, nbody_system, param, t) end if ! The Fraggle disruption model (and its extended types allow for non-pure hit and run. - 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 + 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(COLLISION_LOG_OUT, "Pure hit and run. No new fragments generated.") call self%collision_basic%hitandrun(nbody_system, param, t) return @@ -327,7 +333,8 @@ module subroutine fraggle_generate_merge(self, nbody_system, param, t) if (rotmag < self%max_rot) then call self%collision_basic%merge(nbody_system, param, t) else - call swiftest_io_log_one_message(COLLISION_LOG_OUT, "Merger would break the spin barrier. Converting to pure hit and run" ) + call swiftest_io_log_one_message(COLLISION_LOG_OUT, & + "Merger would break the spin barrier. Converting to pure hit and run" ) impactors%mass_dist(1:2) = impactors%mass(1:2) call self%hitandrun(nbody_system, param, t) end if @@ -342,9 +349,9 @@ module subroutine fraggle_generate_pos_vec(collider, nbody_system, param, lfailu !! Author: Jennifer L.L. Pouplin, Carlisle A. Wishard, and David A. Minton !! !! Initializes the position vectors of the fragments around the center of mass based on the collision style. - !! For hit and run with disruption, the fragments are generated in a random cloud around the smallest of the two colliders (body 2) - !! For disruptive collisions, the fragments are generated in a random cloud around the impact point. Bodies are checked for overlap and - !! regenerated if they overlap. + !! For hit and run with disruption, the fragments are generated in a random cloud around the smallest of the two colliders + !! (body 2). For disruptive collisions, the fragments are generated in a random cloud around the impact point. Bodies are + !! checked for overlap and regenerated if they overlap. implicit none ! Arguments class(collision_fraggle), intent(inout) :: collider !! Fraggle collision system object @@ -372,7 +379,8 @@ module subroutine fraggle_generate_pos_vec(collider, nbody_system, param, lfailu lhitandrun = (impactors%regime == COLLRESOLVE_REGIME_HIT_AND_RUN) ! We will treat the first two fragments of the list as special cases. - ! Place the first two bodies at the centers of the two fragment clouds, but be sure they are sufficiently far apart to avoid overlap + ! Place the first two bodies at the centers of the two fragment clouds, but be sure they are sufficiently far apart to + ! avoid overlap if (lhitandrun) then rdistance = impactors%radius(2) istart = 2 @@ -385,11 +393,14 @@ module subroutine fraggle_generate_pos_vec(collider, nbody_system, param, lfailu end if mass_rscale(1:istart-1) = 1.0_DP - ! Give the fragment positions a random value that is scaled with fragment mass so that the more massive bodies tend to be closer to the impact point - ! Later, velocities will be scaled such that the farther away a fragment is placed from the impact point, the higher will its velocity be. + ! Give the fragment positions a random value that is scaled with fragment mass so that the more massive bodies tend to be + ! closer to the impact point. Later, velocities will be scaled such that the farther away a fragment is placed from the + ! impact point, the higher will its velocity be. call random_number(mass_rscale(istart:nfrag)) mass_rscale(istart:nfrag) = (mass_rscale(istart:nfrag) + 1.0_DP) / 2 - mass_rscale(istart:nfrag) = mass_rscale(istart:nfrag) * (sum(fragments%mass(istart:nfrag)) / fragments%mass(istart:nfrag))**(0.125_DP) ! The power is arbitrary. It just gives the velocity a small mass dependence + ! The power of 0.125 in the scaling below is arbitrary. It just gives the velocity a small mass dependence + mass_rscale(istart:nfrag) = mass_rscale(istart:nfrag) * (sum(fragments%mass(istart:nfrag)) & + / fragments%mass(istart:nfrag))**(0.125_DP) mass_rscale(istart:nfrag) = mass_rscale(istart:nfrag) / minval(mass_rscale(istart:nfrag)) loverlap(:) = .true. @@ -402,8 +413,10 @@ module subroutine fraggle_generate_pos_vec(collider, nbody_system, param, lfailu fragment_cloud_center(:,2) = impactors%rc(:,2) fragments%rc(:,1) = fragment_cloud_center(:,1) else ! Keep the first and second bodies at approximately their original location, but so as not to be overlapping - fragment_cloud_center(:,1) = impactors%rcimp(:) - rbuffer * max(fragments%radius(1),impactors%radius(1)) * impactors%y_unit(:) - fragment_cloud_center(:,2) = impactors%rcimp(:) + rbuffer * max(fragments%radius(2),impactors%radius(2)) * impactors%y_unit(:) + fragment_cloud_center(:,1) = impactors%rcimp(:) - rbuffer * max(fragments%radius(1),& + impactors%radius(1)) * impactors%y_unit(:) + fragment_cloud_center(:,2) = impactors%rcimp(:) + rbuffer * max(fragments%radius(2), & + impactors%radius(2)) * impactors%y_unit(:) fragment_cloud_radius(:) = rdistance / pack_density fragments%rc(:,1:2) = fragment_cloud_center(:,1:2) end if @@ -420,7 +433,8 @@ module subroutine fraggle_generate_pos_vec(collider, nbody_system, param, lfailu ! Randomly place the n>2 fragments inside their cloud until none are overlapping #ifdef DOCONLOC - do concurrent(i = istart:nfrag, loverlap(i)) shared(fragments, impactors, fragment_cloud_radius, fragment_cloud_center, loverlap, mass_rscale, u, phi, theta, lhitandrun) local(j, direction) + do concurrent(i = istart:nfrag, loverlap(i)) shared(fragments, impactors, fragment_cloud_radius, fragment_cloud_center,& + loverlap, mass_rscale, u, phi, theta, lhitandrun) local(j, direction) #else do concurrent(i = istart:nfrag, loverlap(i)) #endif @@ -442,13 +456,15 @@ module subroutine fraggle_generate_pos_vec(collider, nbody_system, param, lfailu ! Stretch out the hit and run cloud along the flight trajectory if (lhitandrun) then - fragments%rc(:,i) = fragments%rc(:,i) * (1.0_DP + 2 * fragment_cloud_radius(j) * mass_rscale(i) * impactors%bounce_unit(:)) + fragments%rc(:,i) = fragments%rc(:,i) * (1.0_DP + 2 * fragment_cloud_radius(j) * mass_rscale(i) & + * impactors%bounce_unit(:)) end if fragments%rc(:,i) = fragments%rc(:,i) + fragment_cloud_center(:,j) if (lhitandrun) then - fragments%rc(:,i) = fragments%rc(:,i) + 2 * fragment_cloud_radius(j) * mass_rscale(i) * impactors%bounce_unit(:) ! Shift the stretched cloud downrange + ! Shift the stretched cloud downrange + fragments%rc(:,i) = fragments%rc(:,i) + 2 * fragment_cloud_radius(j) * mass_rscale(i) * impactors%bounce_unit(:) else ! Make sure that the fragments are positioned away from the impact point direction = dot_product(fragments%rc(:,i) - impactors%rcimp(:), fragment_cloud_center(:,j) - impactors%rcimp(:)) @@ -460,7 +476,8 @@ module subroutine fraggle_generate_pos_vec(collider, nbody_system, param, lfailu end do ! Because body 1 and 2 are initialized near the original impactor positions, then if these bodies are still overlapping - ! when the rest are not, we will randomly walk their position in space so as not to move them too far from their starting position + ! when the rest are not, we will randomly walk their position in space so as not to move them too far from their + ! starting position if (all(.not.loverlap(istart:nfrag)) .and. any(loverlap(1:istart-1))) then #ifdef DOCONLOC do concurrent(i = 1:istart-1,loverlap(i)) shared(fragments,loverlap, u, theta, i) local(rwalk, dis) @@ -525,8 +542,10 @@ module subroutine fraggle_generate_rot_vec(collider, nbody_system, param) class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters ! Internals integer(I4B) :: i, nfrag - real(DP), parameter :: FRAG_ROT_FAC = 0.1_DP ! Fraction of projectile rotation magnitude to add as random noise to fragment rotation - real(DP), parameter :: hitandrun_momentum_transfer = 0.01_DP ! Fraction of projectile momentum transfered to target in a hit and run + real(DP), parameter :: FRAG_ROT_FAC = 0.1_DP ! Fraction of projectile rotation magnitude to add as random noise to fragment + ! rotation + real(DP), parameter :: hitandrun_momentum_transfer = 0.01_DP ! Fraction of projectile momentum transfered to target in a hit + ! and run real(DP) :: mass_fac real(DP), dimension(NDIM) :: drot, dL integer(I4B), parameter :: MAXLOOP = 10 @@ -536,14 +555,15 @@ module subroutine fraggle_generate_rot_vec(collider, nbody_system, param) nfrag = collider%fragments%nbody lhitandrun = (impactors%regime == COLLRESOLVE_REGIME_HIT_AND_RUN) - ! Initialize fragment rotations and velocities to be pre-impact rotation for body 1, and randomized for bodies >1 and scaled to the original rotation. - ! This will get updated later when conserving angular momentum + ! Initialize fragment rotations and velocities to be pre-impact rotation for body 1, and randomized for bodies >1 and + ! scaled to the original rotation. This will get updated later when conserving angular momentum mass_fac = fragments%mass(1) / impactors%mass(1) fragments%rot(:,1) = mass_fac**(5.0_DP/3.0_DP) * impactors%rot(:,1) ! If mass was added, also add spin angular momentum if (mass_fac > 1.0_DP) then - dL(:) = (fragments%mass(1) - impactors%mass(1)) * (impactors%rc(:,2) - impactors%rc(:,1)) .cross. (impactors%vc(:,2) - impactors%vc(:,1)) + dL(:) = (fragments%mass(1) - impactors%mass(1)) * (impactors%rc(:,2) - impactors%rc(:,1)) & + .cross. (impactors%vc(:,2) - impactors%vc(:,1)) drot(:) = dL(:) / (fragments%mass(1) * fragments%radius(1)**2 * fragments%Ip(3,1)) ! Check to make sure we haven't broken the spin barrier. Reduce the rotation change if so do i = 1, MAXLOOP @@ -559,7 +579,8 @@ module subroutine fraggle_generate_rot_vec(collider, nbody_system, param) end if if (lhitandrun) then - dL(:) = hitandrun_momentum_transfer * impactors%mass(2) * (impactors%rc(:,2) - impactors%rc(:,1)) .cross. (impactors%vc(:,2) - impactors%vc(:,1)) + dL(:) = hitandrun_momentum_transfer * impactors%mass(2) * (impactors%rc(:,2) - impactors%rc(:,1)) & + .cross. (impactors%vc(:,2) - impactors%vc(:,1)) drot(:) = dL(:) / (fragments%mass(1) * fragments%radius(1)**2 * fragments%Ip(3,1)) do i = 1, MAXLOOP if (.mag.(fragments%rot(:,1) + drot(:)) < collider%max_rot) exit @@ -580,7 +601,8 @@ module subroutine fraggle_generate_rot_vec(collider, nbody_system, param) do concurrent (i = 2:nfrag) #endif mass_fac = fragments%mass(i) / impactors%mass(2) - fragments%rot(:,i) = mass_fac**(5.0_DP/3.0_DP) * impactors%rot(:,2) + 2 * (fragments%rot(:,i) - 1.0_DP) * FRAG_ROT_FAC * .mag.impactors%rot(:,2) + fragments%rot(:,i) = mass_fac**(5.0_DP/3.0_DP) * impactors%rot(:,2) + 2 * (fragments%rot(:,i) - 1.0_DP) * & + FRAG_ROT_FAC * norm2(impactors%rot(:,2)) end do fragments%rotmag(:) = .mag.fragments%rot(:,:) @@ -603,17 +625,22 @@ module subroutine fraggle_generate_vel_vec(collider, nbody_system, param, lfailu class(swiftest_parameters), intent(inout) :: param !! Current run configuration parameters logical, intent(out) :: lfailure !! Did the velocity computation fail? ! Internals - real(DP), parameter :: ENERGY_SUCCESS_METRIC = 0.1_DP !! Relative energy error to accept as a success (success also must be energy-losing in addition to being within the metric amount) + real(DP), parameter :: ENERGY_SUCCESS_METRIC = 0.1_DP !! Relative energy error to accept as a success (success also must be + !! energy-losing in addition to being within the metric amount) real(DP), parameter :: ENERGY_CONVERGENCE_TOL = 1e-3_DP !! Relative change in error before giving up on energy convergence - real(DP) :: MOMENTUM_SUCCESS_METRIC = 10*epsilon(1.0_DP) !! Relative angular momentum error to accept as a success (should be *much* stricter than energy) + real(DP) :: MOMENTUM_SUCCESS_METRIC = 10*epsilon(1.0_DP) !! Relative angular momentum error to accept as a success + !! (should be *much* stricter than energy) integer(I4B) :: i, j, loop, try, istart, nfrag, nsteps, nsteps_best, posloop logical :: lhitandrun, lsupercat - real(DP), dimension(NDIM) :: vimp_unit, rimp, vrot, vdisp, L_residual, L_residual_unit, L_residual_best, dL, drot, rot_new, dL_metric - real(DP) :: vimp, vmag, vesc, dE, E_residual, E_residual_best, E_residual_last, ke_avail, ke_remove, dE_best, fscale, dE_metric, mfrag, rn, dL1_mag, dE_conv + real(DP), dimension(NDIM) :: vimp_unit, rimp, vrot, vdisp, L_residual, L_residual_unit, L_residual_best, dL, drot, rot_new + real(DP), dimension(NDIM) :: dL_metric + real(DP) :: vimp, vmag, vesc, dE, E_residual, E_residual_best, E_residual_last, ke_avail, ke_remove, dE_best, fscale + real(DP) :: dE_metric, mfrag, rn, dL1_mag, dE_conv, vumag integer(I4B), dimension(:), allocatable :: vsign real(DP), dimension(:), allocatable :: vscale real(DP), dimension(:), allocatable :: dLi_mag - ! For the initial "guess" of fragment velocities, this is the minimum and maximum velocity relative to escape velocity that the fragments will have + ! For the initial "guess" of fragment velocities, this is the minimum and maximum velocity relative to escape velocity that + ! the fragments will have real(DP), parameter :: hitandrun_vscale = 0.25_DP real(DP) :: vmin_guess real(DP) :: vmax_guess @@ -688,25 +715,34 @@ module subroutine fraggle_generate_vel_vec(collider, nbody_system, param, lfailu ! Set the velocities of all fragments using all of the scale factors determined above if (istart > 1) fragments%vc(:,1) = impactors%vc(:,1) * impactors%mass(1) / fragments%mass(1) #ifdef DOCONLOC - do concurrent(i = istart:fragments%nbody) shared(fragments,impactors,lhitandrun, vscale, vesc, vsign) local(j,vrot,vmag,vdisp,rimp,vimp_unit) + do concurrent(i = istart:fragments%nbody) shared(fragments,impactors,lhitandrun, vscale, vesc, vsign) & + local(j,vrot,vmag,vdisp,rimp,vimp_unit, vumag) #else do concurrent(i = istart:fragments%nbody) #endif j = fragments%origin_body(i) - vrot(:) = impactors%rot(:,j) .cross. (fragments%rc(:,i) - impactors%rc(:,j)) + vrot(1) = impactors%rot(2,j) * (fragments%rc(3,i) - impactors%rc(3,j)) & + - impactors%rot(3,j) * (fragments%rc(2,i) - impactors%rc(2,j)) + vrot(2) = impactors%rot(3,j) * (fragments%rc(1,i) - impactors%rc(1,j)) & + - impactors%rot(1,j) * (fragments%rc(3,i) - impactors%rc(3,j)) + vrot(3) = impactors%rot(1,j) * (fragments%rc(2,i) - impactors%rc(2,j)) & + - impactors%rot(2,j) * (fragments%rc(1,i) - impactors%rc(1,j)) if (lhitandrun) then - vdisp(:) = .unit.(fragments%rc(:,i) - impactors%rc(:,2)) * vesc + vumag = norm2(fragments%rc(:,i) - impactors%rc(:,2)) + vdisp(:) = (fragments%rc(:,i) - impactors%rc(:,2)) / vumag * vesc fragments%vc(:,i) = vsign(i) * impactors%bounce_unit(:) * vscale(i) + vrot(:) + vdisp(:) else vmag = vscale(i) rimp(:) = fragments%rc(:,i) - impactors%rcimp(:) - vimp_unit(:) = .unit. (rimp(:) + vsign(i) * impactors%bounce_unit(:)) + vumag = norm2(rimp(:) + vsign(i) * impactors%bounce_unit(:)) + vimp_unit(:) = (rimp(:) + vsign(i) * impactors%bounce_unit(:)) / vumag fragments%vc(:,i) = vmag * vimp_unit(:) + vrot(:) end if end do fragments%vmag(:) = .mag. fragments%vc(:,:) - ! Every time the collision-frame velocities are altered, we need to be sure to shift everything back to the center-of-mass frame + ! Every time the collision-frame velocities are altered, we need to be sure to shift everything back to the + ! center-of-mass frame call collision_util_shift_vector_to_origin(fragments%mass, fragments%vc) call fragments%set_coordinate_system() @@ -715,7 +751,8 @@ module subroutine fraggle_generate_vel_vec(collider, nbody_system, param, lfailu nsteps = nsteps + 1 mfrag = sum(fragments%mass(istart:fragments%nbody)) - ! Try to put residual angular momentum into the spin, but if this would go past the spin barrier, then put it into velocity shear instead + ! Try to put residual angular momentum into the spin, but if this would go past the spin barrier, then put it into + ! velocity shear instead call collider_local%get_energy_and_momentum(nbody_system, param, phase="after") L_residual(:) = (collider_local%L_total(:,2) - collider_local%L_total(:,1)) L_residual_unit(:) = .unit. L_residual(:) @@ -740,7 +777,8 @@ module subroutine fraggle_generate_vel_vec(collider, nbody_system, param, lfailu if (.mag.rot_new(:) < collider_local%max_rot) then fragments%rot(:,i) = rot_new(:) fragments%rotmag(i) = .mag.fragments%rot(:,i) - else ! We would break the spin barrier here. Add a random component of rotation that is less than what would break the limit. The rest will go in velocity shear + else ! We would break the spin barrier here. Add a random component of rotation that is less than what would + ! break the limit. The rest will go in velocity shear call random_number(drot) call random_number(rn) drot(:) = (rn * collider_local%max_rot - fragments%rotmag(i)) * 2 * (drot(:) - 0.5_DP) @@ -785,7 +823,8 @@ module subroutine fraggle_generate_vel_vec(collider, nbody_system, param, lfailu ! Check if we've converged on our constraints if (all(dL_metric(:) <= 1.0_DP)) then - if ((abs(E_residual) < abs(E_residual_best)) .or. ((dE < 0.0_DP) .and. (dE_best >= 0.0_DP))) then ! This is our best case so far. Save it for posterity + if ((abs(E_residual) < abs(E_residual_best)) .or. ((dE < 0.0_DP) .and. (dE_best >= 0.0_DP))) then + ! This is our best case so far. Save it for posterity E_residual_best = E_residual L_residual_best(:) = L_residual(:) dE_best = dE @@ -799,7 +838,8 @@ module subroutine fraggle_generate_vel_vec(collider, nbody_system, param, lfailu if (dE_conv < ENERGY_CONVERGENCE_TOL) exit inner end if - ! Remove a constant amount of velocity from the bodies so we don't shift the center of mass and screw up the momentum + ! Remove a constant amount of velocity from the bodies so we don't shift the center of mass and screw up the + ! momentum ke_avail = 0.0_DP do i = fragments%nbody, 1, -1 ke_avail = ke_avail + 0.5_DP * fragments%mass(i) * max(fragments%vmag(i) - vesc / try,0.0_DP)**2 @@ -830,9 +870,11 @@ module subroutine fraggle_generate_vel_vec(collider, nbody_system, param, lfailu write(message, *) nsteps if (lfailure) then - call swiftest_io_log_one_message(COLLISION_LOG_OUT, "Fraggle velocity calculation failed to converge after " // trim(adjustl(message)) // " steps. The best solution found had:") + call swiftest_io_log_one_message(COLLISION_LOG_OUT, "Fraggle velocity calculation failed to converge after " & + // trim(adjustl(message)) // " steps. The best solution found had:") else - call swiftest_io_log_one_message(COLLISION_LOG_OUT,"Fraggle velocity calculation converged after " // trim(adjustl(message)) // " steps.") + call swiftest_io_log_one_message(COLLISION_LOG_OUT,"Fraggle velocity calculation converged after " & + // trim(adjustl(message)) // " steps.") call collider%get_energy_and_momentum(nbody_system, param, phase="after") L_residual(:) = (collider%L_total(:,2) - collider%L_total(:,1)) diff --git a/src/operator/operator_cross.f90 b/src/operator/operator_cross.f90 index ef80e1fb8..72c24a176 100644 --- a/src/operator/operator_cross.f90 +++ b/src/operator/operator_cross.f90 @@ -104,11 +104,7 @@ pure module function operator_cross_el_sp(A, B) result(C) n = size(A, 2) if (allocated(C)) deallocate(C) allocate(C, mold = A) -#ifdef DOCONLOC - do concurrent (i = 1:n) shared(A,B,C) -#else - do concurrent (i = 1:n) -#endif + do i = 1,n C(:,i) = operator_cross_sp(A(:,i), B(:,i)) end do return @@ -122,11 +118,7 @@ pure module function operator_cross_el_dp(A, B) result(C) n = size(A, 2) if (allocated(C)) deallocate(C) allocate(C, mold = A) -#ifdef DOCONLOC - do concurrent (i = 1:n) shared(A,B,C) -#else - do concurrent (i = 1:n) -#endif + do i = 1,n C(:,i) = operator_cross_dp(A(:,i), B(:,i)) end do return @@ -140,11 +132,7 @@ pure module function operator_cross_el_qp(A, B) result(C) n = size(A, 2) if (allocated(C)) deallocate(C) allocate(C, mold = A) -#ifdef DOCONLOC - do concurrent (i = 1:n) shared(A,B,C) -#else - do concurrent (i = 1:n) -#endif + do i = 1,n C(:,i) = operator_cross_qp(A(:,i), B(:,i)) end do return @@ -158,11 +146,7 @@ pure module function operator_cross_el_i1b(A, B) result(C) n = size(A, 2) if (allocated(C)) deallocate(C) allocate(C, mold = A) -#ifdef DOCONLOC - do concurrent (i = 1:n) shared(A,B,C) -#else - do concurrent (i = 1:n) -#endif + do i = 1,n C(:,i) = operator_cross_i1b(A(:,i), B(:,i)) end do return @@ -176,11 +160,7 @@ pure module function operator_cross_el_i2b(A, B) result(C) n = size(A, 2) if (allocated(C)) deallocate(C) allocate(C, mold = A) -#ifdef DOCONLOC - do concurrent (i = 1:n) shared(A,B,C) -#else - do concurrent (i = 1:n) -#endif + do i = 1,n C(:,i) = operator_cross_i2b(A(:,i), B(:,i)) end do return @@ -194,11 +174,7 @@ pure module function operator_cross_el_i4b(A, B) result(C) n = size(A, 2) if (allocated(C)) deallocate(C) allocate(C, mold = A) -#ifdef DOCONLOC - do concurrent (i = 1:n) shared(A,B,C) -#else - do concurrent (i = 1:n) -#endif + do i = 1,n C(:,i) = operator_cross_i4b(A(:,i), B(:,i)) end do return @@ -212,11 +188,7 @@ pure module function operator_cross_el_i8b(A, B) result(C) n = size(A, 2) if (allocated(C)) deallocate(C) allocate(C, mold = A) -#ifdef DOCONLOC - do concurrent (i = 1:n) shared(A,B,C) -#else - do concurrent (i = 1:n) -#endif + do i = 1,n C(:,i) = operator_cross_i8b(A(:,i), B(:,i)) end do return diff --git a/src/operator/operator_mag.f90 b/src/operator/operator_mag.f90 index 55f653fb9..721e4a930 100644 --- a/src/operator/operator_mag.f90 +++ b/src/operator/operator_mag.f90 @@ -44,11 +44,7 @@ pure module function operator_mag_el_sp(A) result(B) if (allocated(B)) deallocate(B) allocate(B(n)) call ieee_set_halting_mode(ieee_underflow, .false.) -#ifdef DOCONLOC - do concurrent (i = 1:n) shared(A,B) -#else - do concurrent (i = 1:n) -#endif + do i = 1,n B(i) = norm2(A(:, i)) end do return @@ -63,11 +59,7 @@ pure module function operator_mag_el_dp(A) result(B) if (allocated(B)) deallocate(B) allocate(B(n)) call ieee_set_halting_mode(ieee_underflow, .false.) -#ifdef DOCONLOC - do concurrent (i = 1:n) shared(A,B) -#else - do concurrent (i = 1:n) -#endif + do i = 1,n B(i) = norm2(A(:, i)) end do return @@ -82,11 +74,7 @@ pure module function operator_mag_el_qp(A) result(B) if (allocated(B)) deallocate(B) allocate(B(n)) call ieee_set_halting_mode(ieee_underflow, .false.) -#ifdef DOCONLOC - do concurrent (i = 1:n) shared(A,B) -#else - do concurrent (i = 1:n) -#endif + do i = 1,n B(i) = norm2(A(:, i)) end do return diff --git a/src/operator/operator_unit.f90 b/src/operator/operator_unit.f90 index a25ee1bb1..2a14f6645 100644 --- a/src/operator/operator_unit.f90 +++ b/src/operator/operator_unit.f90 @@ -89,11 +89,7 @@ pure module function operator_unit_el_sp(A) result(B) if (allocated(B)) deallocate(B) allocate(B(NDIM,n)) -#ifdef DOCONLOC - do concurrent (i=1:n) shared(A,B) -#else - do concurrent (i=1:n) -#endif + do i=1,n B(:,i) = operator_unit_sp(A(:,i)) end do @@ -113,11 +109,7 @@ pure module function operator_unit_el_dp(A) result(B) if (allocated(B)) deallocate(B) allocate(B(NDIM,n)) -#ifdef DOCONLOC - do concurrent (i=1:n) shared(A,B) -#else - do concurrent (i=1:n) -#endif + do i=1,n B(:,i) = operator_unit_dp(A(:,i)) end do @@ -136,11 +128,7 @@ pure module function operator_unit_el_qp(A) result(B) if (allocated(B)) deallocate(B) allocate(B(NDIM,n)) -#ifdef DOCONLOC - do concurrent (i=1:n) shared(A,B) -#else - do concurrent (i=1:n) -#endif + do i=1,n B(:,i) = operator_unit_qp(A(:,i)) end do