From d6af633ca06ad14d50bfaa4b9acbd3229eb5c528 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Thu, 18 Jan 2024 14:18:09 +0100 Subject: [PATCH 01/45] (CE-analysis) add comments to potential energy calculation in calculate_energies --- src/utils/analysis_common_envelope.f90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 6cd1c6c27..aba02cdbe 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -793,7 +793,7 @@ subroutine calculate_energies(time,npart,particlemass,xyzh,vxyzu) real :: rhopart,ponrhoi,spsoundi,tempi,r_ij,radvel real, dimension(3) :: rcrossmv character(len=17), allocatable :: columns(:) - integer :: i, j, ncols + integer :: i,j,ncols logical :: inearsink integer, parameter :: ie_tot = 1 integer, parameter :: ie_pot = ie_tot + 1 @@ -826,9 +826,9 @@ subroutine calculate_energies(time,npart,particlemass,xyzh,vxyzu) ' pot energy',& ' kin energy',& 'therm energy',& - ' sink pot',& + ' sink pot',& ! does not include sink-gas potential energy ' sink kin',& - ' sink orb',& + ' sink orb',& ! sink kin + sink pot ' comp orb',& ' env pot',& ' env energy',& @@ -914,7 +914,7 @@ subroutine calculate_energies(time,npart,particlemass,xyzh,vxyzu) do j=i+1,nptmass if (xyzmh_ptmass(4,j) > 0.) then r_ij = separation(xyzmh_ptmass(1:3,i),xyzmh_ptmass(1:3,j)) - encomp(ipot_sink) = encomp(ipot_sink) - xyzmh_ptmass(4,i) * xyzmh_ptmass(4,j) / r_ij + encomp(ipot_sink) = encomp(ipot_sink) - xyzmh_ptmass(4,i) * xyzmh_ptmass(4,j) / r_ij ! Newtonian expression is fine as long as rij > hsofti + hsoftj if (i==1 .and. j==2) encomp(iorb_comp) = encomp(iorb_comp) - xyzmh_ptmass(4,i) * xyzmh_ptmass(4,j) / r_ij endif enddo From aa546cda0c6f32ec8e318a5c49368312cfd398f5 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Thu, 18 Jan 2024 14:18:46 +0100 Subject: [PATCH 02/45] (CE-analysis) add sound speed to energy_profile --- src/utils/analysis_common_envelope.f90 | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index aba02cdbe..629645cb2 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -2064,11 +2064,12 @@ subroutine energy_profile(time,npart,particlemass,xyzh,vxyzu) if (dump_number==0) then iquantity = 1 use_mass_coord = .false. - print "(4(/,a))",'1. Energy',& + print "(5(/,a))",'1. Energy',& '2. Entropy',& '3. Bernoulli energy',& - '4. Ion fractions' - call prompt("Select quantity to calculate",iquantity,1,4) + '4. Ion fractions',& + '5. Sound speed' + call prompt("Select quantity to calculate",iquantity,1,5) call prompt("Bin in mass coordinates instead of radius?",use_mass_coord) endif @@ -2087,7 +2088,7 @@ subroutine energy_profile(time,npart,particlemass,xyzh,vxyzu) call compute_energies(time) ! Allocate arrays for single variable outputs - if ( (iquantity==1) .or. (iquantity==2) .or. (iquantity==3) ) then + if (iquantity==1 .or. iquantity==2 .or. iquantity==3 .or. iquantity==5) then nvars = 1 else nvars = 5 @@ -2127,6 +2128,9 @@ subroutine energy_profile(time,npart,particlemass,xyzh,vxyzu) ' # HeI', & ' # HeII', & ' # HeIII' /) + case(5) ! Sound speed + filename = ' grid_cs.ev' + headerline = '# cs profile ' end select allocate(iorder(npart)) @@ -2174,6 +2178,8 @@ subroutine energy_profile(time,npart,particlemass,xyzh,vxyzu) quant(i,3) = xhe0 quant(i,4) = xhe1 quant(i,5) = xhe2 + case(5) ! Sound speed + quant(i,1) = spsoundi end select enddo From c782b8b4226ec7d2449c5668f1e43e635c763511 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 3 Apr 2024 14:39:45 +1100 Subject: [PATCH 03/45] Add group indentification, first parts of TTL integration scheme and kepler utils.. --- build/Makefile | 4 + src/main/part.F90 | 22 +++ src/main/sdar_group.f90 | 315 ++++++++++++++++++++++++++++++++++++++ src/main/utils_kepler.f90 | 114 ++++++++++++++ src/main/utils_sdar.f90 | 17 ++ 5 files changed, 472 insertions(+) create mode 100644 src/main/sdar_group.f90 create mode 100644 src/main/utils_kepler.f90 create mode 100644 src/main/utils_sdar.f90 diff --git a/build/Makefile b/build/Makefile index 7056a4d0c..4d3da5a7a 100644 --- a/build/Makefile +++ b/build/Makefile @@ -275,6 +275,10 @@ ifeq ($(RADIATION), yes) endif ifeq ($(FOURTHORDER), yes) + FPPFLAGS += -DFOURTHORDER +endif + +ifeq ($(NBODYREG), yes) FPPFLAGS += -DNBODYREG endif diff --git a/src/main/part.F90 b/src/main/part.F90 index 27c6391f7..fe849c8d3 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -281,6 +281,23 @@ module part ! real(kind=4), allocatable :: luminosity(:) ! +!-- Regularisation algorithm allocation +! +#ifdef NBODYREG + integer, allocatable :: group_info(:,:) + integer(kind=1), allocatable :: nmatrix(:,:) + integer, parameter :: igarg = 1 ! idx of the particle member of a group + integer, parameter :: igid = 2 ! id of the group (may be unescessary) + integer, parameter :: igsize = 3 ! size of the group (may be unescessary) + integer, parameter :: igcum = 4 ! cumulative sum of the indices to find the starting and ending point of a group + ! needed for group identification and sorting + integer :: ngroup = 0 + integer :: n_ingroup = 0 + integer :: n_sing = 0 + ! Gradient of the time transformation function + real, allocatable :: gtgrad(:,:) +#endif +! !--derivatives (only needed if derivs is called) ! real, allocatable :: fxyzu(:,:) @@ -461,6 +478,9 @@ subroutine allocate_part call allocate_array('abundance', abundance, nabundances, maxp_h2) endif call allocate_array('T_gas_cool', T_gas_cool, maxp_krome) + call allocate_array('group_info', group_info, 4, maxptmass) + call allocate_array("nmatrix", nmatrix, maxptmass, maxptmass) + call allocate_array("gtgrad", gtgrad, 3, maxptmass) end subroutine allocate_part @@ -533,6 +553,8 @@ subroutine deallocate_part if (allocated(ibelong)) deallocate(ibelong) if (allocated(istsactive)) deallocate(istsactive) if (allocated(ibin_sts)) deallocate(ibin_sts) + if (allocated(group_info)) deallocate(group_info) + if (allocated(nmatrix)) deallocate(nmatrix) end subroutine deallocate_part diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 new file mode 100644 index 000000000..3687c41c5 --- /dev/null +++ b/src/main/sdar_group.f90 @@ -0,0 +1,315 @@ +module sdar_group +! +! this module contains everything to identify +! and integrate regularized groups... +! +! :References: Makino et Aarseth 2002,Wang et al. 2020, Wang et al. 2021, Rantala et al. 2023 +! +! :Owner: Daniel Price +! + implicit none + public :: group_identify + public :: evolve_groups + ! parameters for group identification + real, public :: r_neigh = 0.0 + real, public :: t_crit = 0.0 + real, public :: C_bin = 0.0 + real, public :: r_search = 0.0 + private +contains + +! +! +! Group identification routines +! +! +subroutine group_identify(nptmass,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) + real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + integer, intent(in) :: group_info(:,:) + integer(kind=1), intent(inout) :: nmatrix(:,:) + integer, intent(in) :: nptmass + + ngroup = 0 + n_ingroup = 0 + n_sing = 0 + call matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) + call form_group(group_info,nmatrix,nptmass) + +end subroutine group_identify + + +subroutine form_group(group_info,nmatrix,nptmass) + use part, only : igid,igarg,igsize,igcum + integer(kind=1), intent(in) :: nmatrix(:,:) + integer, intent(out):: group_info(:,:) + integer, intent(in) :: nptmass + integer :: i + logical :: visited(nptmass) + do i=1,nptmass + if(.not.visited(i)) then + n_ingroup = n_ingroup + 1 + call dfs(i,i,visited,group_info,nmatrix,nptmass,n_ingroup) + if (group_info(igsize,i)>1)then + ngroup = ngroup + 1 + group_info(igcum,ngroup+1) = group_info(igsize,i) + group_info(igcum,ngroup) + else + n_ingroup= n_ingroup - 1 + group_info(igsize,i) = 0 + group_info(igarg,nptmass-n_sing) = i + group_info(igid,nptmass-n_sing) = 0 + n_sing = n_sing + 1 + endif + endif + enddo +end subroutine form_group + +recursive subroutine dfs(inode,iroot,visited,group_info,nmatrix,npt,n_ingroup) + use part, only : igid,igarg,igsize,igcum + integer, intent(in) :: inode,npt,iroot + integer(kind=1), intent(in) :: nmatrix(:,:) + integer, intent(inout) :: group_info(:,:) + integer, intent(inout) :: n_ingroup + logical, intent(inout) :: visited(:) + integer :: j + !print*,nping,inode + group_info(igarg,n_ingroup) = inode + group_info(igid,n_ingroup) = iroot + group_info(igsize,iroot) = group_info(igsize,iroot)+1 + visited(inode) = .true. + do j=1,npt + if (nmatrix(inode,j)==1 .and. (visited(j).eqv..false.)) then + n_ingroup = n_ingroup + 1 + call dfs(j,iroot,visited,group_info,nmatrix,npt,n_ingroup) + endif + enddo +end subroutine dfs + + +subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) + use utils_kepler, only: bindE,extract_a,extract_e,extract_ea + integer(kind=1), intent(out):: nmatrix(:,:) + real, intent(in) :: xyzmh_ptmass(:,:) + real, intent(in) :: vxyz_ptmass(:,:) + integer, intent(in) :: nptmass + real :: xi,yi,zi,vxi,vyi,vzi,mi + real :: dx,dy,dz,dvx,dvy,dvz,r2,r,v2,mu + real :: aij,eij,B,rperi + integer :: i,j + + nmatrix = 0. + + do i=1,nptmass + xi = xyzmh_ptmass(1,i) + yi = xyzmh_ptmass(2,i) + zi = xyzmh_ptmass(3,i) + mi = xyzmh_ptmass(4,i) + vxi = vxyz_ptmass(1,i) + vyi = vxyz_ptmass(2,i) + vzi = vxyz_ptmass(3,i) + do j=1,nptmass + if(i==j) cycle + if(j>i) then + dx = xi - xyzmh_ptmass(1,j) + dy = yi - xyzmh_ptmass(2,j) + dz = zi - xyzmh_ptmass(3,j) + r2 = dx**2+dy**2+dz**2 + r = sqrt(r2) + if (rr_search) then + nmatrix(i,j) = 0 + cycle + endif + mu = mi + xyzmh_ptmass(4,j) + dvx = vxi - vxyz_ptmass(1,j) + dvy = vyi - vxyz_ptmass(2,j) + dvz = vzi - vxyz_ptmass(3,j) + v2 = dvx**2+dvy**2+dvz**2 + call bindE(v2,r,mu,B) + call extract_a(r,mu,v2,aij) + if (B<0) then + if (aij=1) then + eij = 0. + else + eij = sqrt(1-neg_e) + endif + +end subroutine extract_ea + +subroutine extract_kep_elmt(x,y,z,vx,vy,vz,mu,r,a,e,i,argp,longi,M) + real, intent(in) :: x,y,z,vx,vy,vz,mu,r + real, intent(out):: a,e,i,argp,longi,M + real :: hx,hy,hz,ex,ey,ez,v2,h,anoE,nu + real :: rdote,n,ndote + + v2 = vx**2+vy**2+vz**2 + + a = (r*mu)/(2*mu-r*v2) + + hx = y*vz-z*vy + hy = z*vx-x*vz + hz = x*vy-y*vx + + h = sqrt(hx*2+hy**2+hz**2) + i = acos(hz/h) + + ex = (vy*hz-vz*hy)/mu - x/r + ey = (vz*hx-vx*hz)/mu - y/r + ez = (vx*hy-hx*vy)/mu - z/r + + e = sqrt(ex**2+ey**2+ez**2) + + rdote = x*ex+y*ey+z*ez + + if (x*vx+y*vy+z*vz>=0) then + nu = acos(rdote/(e*r)) + else + nu = 2*pi - acos(rdote/(e*r)) + endif + anoE = tan(nu*0.5)/sqrt((1+e)/(1-e)) + anoE = 2*atan(anoE) + + M = E-e*sin(E) + + n = sqrt(hy**2+hx**2) + if (hx>=0) then + longi = acos(-hy/n) + else + longi = 2*pi - acos(-hy/n) + endif + + ndote = -hy*ex + hx*ey + if (ez>=0) then + argp = acos(ndote/(n*e)) + else + argp = 2*pi - acos(ndote/(n*e)) + endif + +end subroutine extract_kep_elmt + + + + +end module utils_kepler diff --git a/src/main/utils_sdar.f90 b/src/main/utils_sdar.f90 new file mode 100644 index 000000000..553489996 --- /dev/null +++ b/src/main/utils_sdar.f90 @@ -0,0 +1,17 @@ +module utils_sdar + implicit none + real, dimension(8),parameter :: ck=(/0.3922568052387800,0.5100434119184585,-0.4710533854097566,& + 0.0687531682525181,0.0687531682525181,-0.4710533854097566,& + 0.5100434119184585,0.3922568052387800/) + real, dimension(8),parameter :: cck_sorted=(/0.0976997828427615,0.3922568052387800,0.4312468317474820,& + 0.5000000000000000,0.5687531682525181,0.6077431947612200,& + 0.9023002171572385,1.0000000000000000/) + real, dimension(8),parameter :: dk=(/0.7845136104775600,0.2355732133593570,-1.1776799841788701,& + 1.3151863206839063,-1.1776799841788701,0.2355732133593570,& + 0.7845136104775600,0.0000000000000000/) + integer, dimension(8),parameter :: cck_sorted_id=(/6,1,3,4,5,7,2,8/) + + +contains + +end module utils_sdar From d74d3586a8c0f0e69a4c45a90084f44285095dbd Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 4 Apr 2024 10:13:24 +1100 Subject: [PATCH 04/45] add main integration routine for subsystems, still need to fix the backup data array... --- src/main/options.f90 | 2 + src/main/sdar_group.f90 | 247 +++++++++++++++++++++++++++++++++++++++- src/main/utils_sdar.f90 | 9 +- 3 files changed, 248 insertions(+), 10 deletions(-) diff --git a/src/main/options.f90 b/src/main/options.f90 index 0312c9371..5e49a8f40 100644 --- a/src/main/options.f90 +++ b/src/main/options.f90 @@ -60,6 +60,7 @@ module options ! Regularisation method and/or higher order integrator logical, public :: use_fourthorder + logical, public :: use_regnbody public :: set_default_options @@ -175,6 +176,7 @@ subroutine set_default_options use_var_comp = .false. use_fourthorder = .false. + use_regnbody = .false. end subroutine set_default_options diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index 3687c41c5..6340c4c25 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -7,6 +7,7 @@ module sdar_group ! ! :Owner: Daniel Price ! + use utils_sdar implicit none public :: group_identify public :: evolve_groups @@ -18,11 +19,11 @@ module sdar_group private contains -! +!----------------------------------------------- ! ! Group identification routines ! -! +!----------------------------------------------- subroutine group_identify(nptmass,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) integer, intent(in) :: group_info(:,:) @@ -146,11 +147,11 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) enddo end subroutine matrix_construction -! +!--------------------------------------------- ! ! Routines needed to integrate subgroups ! -! +!--------------------------------------------- subroutine evolve_groups(n_group,tnext,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) use part, only: igid,igarg,igsize,igcum @@ -174,16 +175,192 @@ subroutine evolve_groups(n_group,tnext,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ end subroutine evolve_groups -subroutine integrate_to_time() +subroutine integrate_to_time(start_id,end_id,gsize,ds_init,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:), & + fxyz_ptmass(:,:),gtgrad(:,:) + integer, intent(in) :: start_id,end_id,gsize + real, intent(in) :: ds_init + real :: ds(2) + real :: timetable(ck_size) + integer :: switch + integer :: step_count_int,step_count_tsyn,n_step_end + real :: dt,dt_end,step_modif,t_old,W_old + logical :: t_end_flag,backup_flag + integer :: i + + step_count_int = 0 + step_count_tsyn = 0 + n_step_end = 0 + t_end_flag = .false. + backup_flag = .true. + ds = ds_init + switch = 1 + + do while (.true.) + + if (backup_flag) then + call backup_data(gsize,xyzmh_ptmass,vxyz_ptmass,bdata) + else + call restore_state(gsize,xyzmh_ptmass,vxyz_ptmass,tcoord,t_old,W,W_old,bdata) + endif + t_old = tcoord + W_old = W + if (gsize>1) then + do i=1,ck_size + call drift_TTL (gsize,xyzmh_ptmass,vxyz_ptmass,ds(switch)*ck(i), & + tcoord,W,start_id,end_id) + time_table(i) = tcoord + call kick_TTL (gsize,xyzmh_ptmass,vxyz_ptmass,fxyz,gtgrad, & + ds(switch)*dk(i),W,om,start_id,end_id) + enddo + else + call oneStep_bin(gsize,xyzmh_ptmass,vxyz_ptmass,fxyz,gtgrad, & + ds(switch),tcoord,W,om,time_table,start_id,end_id) + endif + dt = tcoord - t_old + + step_count_int = step_count_int + 1 + + if(step_count_int > max_step) then + print*,"MAX STEP NUMBER, ABORT !!!" + call abort + endif + + if ((.not.t_end_flag).and.(dt<0.)) then + !print*,"neg dt !!!",tnext,dt + call regularstepfactor((abs(tnext/dt))**(1./6.),step_modif) + step_modif = min(max(step_modif,0.0625),0.5) + ds(switch) = ds(switch)*step_modif + ds(3-switch) = ds(switch) + + backup_flag = .false. + continue + endif + + if (tcoord < tnext - time_error) then + if (t_end_flag .and. (ds(switch)==ds(3-switch))) then + step_count_tsyn = step_count_tsyn + 1 + dt_end = tnext - tcoord + if (dt<0.) then + call regularstepfactor((abs(tnext/dt))**(1./6.),step_modif) + step_modif = min(max(step_modif,0.0625),0.5) + ds(switch) = ds(switch)*step_modif + ds(3-switch) = ds(switch) + else if ((n_step_end > 1) .and. (dt<0.3*dt_end)) then + ds(3-switch) = ds(switch) * dt_end/dt + else + n_step_end = n_step_end + 1 + endif + endif + ds(switch) = ds(3-switch) + switch = 3 - switch + if (dt>0) then + backup_flag = .true. + else + backup_flag = .false. + endif + + else if (tcoord > tnext + time_error) then + t_end_flag = .true. + backup_flag = .false. + n_step_end = 0 + step_count_tsyn = step_count_tsyn + 1 + + call new_ds_sync_sup(ds,time_table,tnext,switch) + else + exit + endif + enddo end subroutine integrate_to_time +subroutine regularstepfactor(fac_in,fac_out) + real, intent(in) :: fac_in + real, intent(out):: fac_out + fac_out = 1.0 + if (fac_in<1) then + do while (fac_out>fac_in) + fac_out = fac_out*0.5 + enddo + else + do while(fac_out<=fac_in) + fac_out = fac_out *2 + enddo + fac_out = fac_out*0.5 + endif +end subroutine regularstepfactor + +subroutine new_ds_sync_sup(ds,time_table,tnext,switch) + real, intent(inout) :: ds(:) + real, intent(in) :: time_table(:) + real, intent(in) :: tnext + integer, intent(in) :: switch + integer :: i,k + real :: tp,dtk,dstmp + do i=1,ck_size + k = cck_sorted_id(i) + if(tnext Date: Fri, 5 Apr 2024 13:00:46 +1100 Subject: [PATCH 05/45] remove last comp flag and new version of form group without recursion --- src/main/part.F90 | 8 ++---- src/main/sdar_group.f90 | 54 ++++++++++++++++++++++++----------------- 2 files changed, 34 insertions(+), 28 deletions(-) diff --git a/src/main/part.F90 b/src/main/part.F90 index fe849c8d3..9cc2e8c25 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -283,20 +283,16 @@ module part ! !-- Regularisation algorithm allocation ! -#ifdef NBODYREG integer, allocatable :: group_info(:,:) integer(kind=1), allocatable :: nmatrix(:,:) integer, parameter :: igarg = 1 ! idx of the particle member of a group - integer, parameter :: igid = 2 ! id of the group (may be unescessary) - integer, parameter :: igsize = 3 ! size of the group (may be unescessary) - integer, parameter :: igcum = 4 ! cumulative sum of the indices to find the starting and ending point of a group + integer, parameter :: igcum = 2 ! cumulative sum of the indices to find the starting and ending point of a group ! needed for group identification and sorting integer :: ngroup = 0 integer :: n_ingroup = 0 integer :: n_sing = 0 ! Gradient of the time transformation function real, allocatable :: gtgrad(:,:) -#endif ! !--derivatives (only needed if derivs is called) ! @@ -478,7 +474,7 @@ subroutine allocate_part call allocate_array('abundance', abundance, nabundances, maxp_h2) endif call allocate_array('T_gas_cool', T_gas_cool, maxp_krome) - call allocate_array('group_info', group_info, 4, maxptmass) + call allocate_array('group_info', group_info, 2, maxptmass) call allocate_array("nmatrix", nmatrix, maxptmass, maxptmass) call allocate_array("gtgrad", gtgrad, 3, maxptmass) diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index 6340c4c25..43cfd0366 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -39,49 +39,59 @@ subroutine group_identify(nptmass,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) end subroutine group_identify -subroutine form_group(group_info,nmatrix,nptmass) - use part, only : igid,igarg,igsize,igcum +subroutine form_group(nmatrix,nptmass,group_info) + use part, only : igid,igcum + use dim, only : maxptmass integer(kind=1), intent(in) :: nmatrix(:,:) integer, intent(out):: group_info(:,:) integer, intent(in) :: nptmass - integer :: i - logical :: visited(nptmass) + integer :: i,ncg + logical :: visited(maxptmass) + integer :: stack(maxptmass) do i=1,nptmass if(.not.visited(i)) then n_ingroup = n_ingroup + 1 - call dfs(i,i,visited,group_info,nmatrix,nptmass,n_ingroup) - if (group_info(igsize,i)>1)then + call dfs(i,i,visited,stack,group_info,nmatrix,nptmass,n_ingroup,ncg) + if (ncg>1)then ngroup = ngroup + 1 - group_info(igcum,ngroup+1) = group_info(igsize,i) + group_info(igcum,ngroup) + group_info(igcum,ngroup+1) = ncg + group_info(igcum,ngroup) else - n_ingroup= n_ingroup - 1 - group_info(igsize,i) = 0 + n_ingroup = n_ingroup - 1 group_info(igarg,nptmass-n_sing) = i - group_info(igid,nptmass-n_sing) = 0 n_sing = n_sing + 1 endif endif enddo end subroutine form_group -recursive subroutine dfs(inode,iroot,visited,group_info,nmatrix,npt,n_ingroup) - use part, only : igid,igarg,igsize,igcum - integer, intent(in) :: inode,npt,iroot +subroutine dfs(inode,iroot,visited,stack,group_info,nmatrix,nptmass,n_ingroup,ncg) + use part, only : igarg + integer, intent(in) :: inode,nptmass,iroot + integer, intent(out) :: ncg integer(kind=1), intent(in) :: nmatrix(:,:) integer, intent(inout) :: group_info(:,:) integer, intent(inout) :: n_ingroup + integer, intent(out) :: stack(:) logical, intent(inout) :: visited(:) - integer :: j - !print*,nping,inode + integer :: j,stack_top + + ncg = 1 group_info(igarg,n_ingroup) = inode - group_info(igid,n_ingroup) = iroot - group_info(igsize,iroot) = group_info(igsize,iroot)+1 + stack_top = stack_top + 1 + stack(stack_top) = inode visited(inode) = .true. - do j=1,npt - if (nmatrix(inode,j)==1 .and. (visited(j).eqv..false.)) then - n_ingroup = n_ingroup + 1 - call dfs(j,iroot,visited,group_info,nmatrix,npt,n_ingroup) - endif + do while(stack_top>0) + inode = stack(stack_top) + stack_top = stack_top - 1 + do j= 1,nptmass + if (nmatrix(inode,j)==1 .and. .not.(visited(j))) then + n_ingroup = n_ingroup + 1 + stack_top = stack_top + 1 + stack(stack_top) = j + visited(j) = .true. + group_info(igarg,n_ingroup) = j + endif + enddo enddo end subroutine dfs From 751fd8106bbb2e5611fa27e35eccaa2332615b3f Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 5 Apr 2024 13:13:56 +1100 Subject: [PATCH 06/45] parallel version for adjacency matrix construction --- src/main/sdar_group.f90 | 65 +++++++++++++++++++++-------------------- 1 file changed, 33 insertions(+), 32 deletions(-) diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index 43cfd0366..45d2821c2 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -107,8 +107,12 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) real :: aij,eij,B,rperi integer :: i,j - nmatrix = 0. - + !$omp parallel do default(none) & + !$omp shared(nptmass,r_neigh,C_bin,t_crit,nmatrix) & + !$omp private(xi,yi,zi,mi,vxi,vyi,vzi,i,j) & + !$omp private(dx,dy,dz,r,r2) & + !$omp private(dvx,dvy,dvz,v2) & + !$omp private(mu,aij,eij,B,r_peri) & do i=1,nptmass xi = xyzmh_ptmass(1,i) yi = xyzmh_ptmass(2,i) @@ -119,42 +123,39 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) vzi = vxyz_ptmass(3,i) do j=1,nptmass if(i==j) cycle - if(j>i) then - dx = xi - xyzmh_ptmass(1,j) - dy = yi - xyzmh_ptmass(2,j) - dz = zi - xyzmh_ptmass(3,j) - r2 = dx**2+dy**2+dz**2 - r = sqrt(r2) - if (rr_search) then + nmatrix(i,j) = 0 + cycle + endif + mu = mi + xyzmh_ptmass(4,j) + dvx = vxi - vxyz_ptmass(1,j) + dvy = vyi - vxyz_ptmass(2,j) + dvz = vzi - vxyz_ptmass(3,j) + v2 = dvx**2+dvy**2+dvz**2 + call bindE(v2,r,mu,B) + call extract_a(r,mu,v2,aij) + if (B<0) then + if (aijr_search) then - nmatrix(i,j) = 0 - cycle - endif - mu = mi + xyzmh_ptmass(4,j) - dvx = vxi - vxyz_ptmass(1,j) - dvy = vyi - vxyz_ptmass(2,j) - dvz = vzi - vxyz_ptmass(3,j) - v2 = dvx**2+dvy**2+dvz**2 - call bindE(v2,r,mu,B) - call extract_a(r,mu,v2,aij) - if (B<0) then - if (aij Date: Fri, 5 Apr 2024 16:25:14 +1100 Subject: [PATCH 07/45] add subsytem time_step calculation --- src/main/sdar_group.f90 | 106 +++++++++++++++++++++++++++++--------- src/main/utils_kepler.f90 | 14 +++-- 2 files changed, 94 insertions(+), 26 deletions(-) diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index 45d2821c2..92588763b 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -16,6 +16,7 @@ module sdar_group real, public :: t_crit = 0.0 real, public :: C_bin = 0.0 real, public :: r_search = 0.0 + real, parameter :: eta_pert = 0.02 private contains @@ -97,7 +98,7 @@ end subroutine dfs subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) - use utils_kepler, only: bindE,extract_a,extract_e,extract_ea + use utils_kepler, only: Espec,extract_a,extract_e,extract_ea integer(kind=1), intent(out):: nmatrix(:,:) real, intent(in) :: xyzmh_ptmass(:,:) real, intent(in) :: vxyz_ptmass(:,:) @@ -140,7 +141,7 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) dvy = vyi - vxyz_ptmass(2,j) dvz = vzi - vxyz_ptmass(3,j) v2 = dvx**2+dvy**2+dvz**2 - call bindE(v2,r,mu,B) + call Espec(v2,r,mu,B) call extract_a(r,mu,v2,aij) if (B<0) then if (aij 2 + + call initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,om,s_id,e_id,ismultiple,ds_init) + step_count_int = 0 step_count_tsyn = 0 n_step_end = 0 @@ -480,7 +487,7 @@ subroutine oneStep_bin(gsize,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,ds,tcoo end subroutine oneStep_bin -subroutine get_force_TTL(xyzmh_ptmass,om,fxyz_ptmass,gtgrad,s_id,e_id) +subroutine get_force_TTL(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,s_id,e_id) real, intent(in) :: xyzmh_ptmass(:,:) real, intent(inout) :: fxyz_ptmass(:,:),gtgrad(:,:) real, intent(out) :: om @@ -500,10 +507,10 @@ subroutine get_force_TTL(xyzmh_ptmass,om,fxyz_ptmass,gtgrad,s_id,e_id) do i=s_id,e_id gtki = 0. - xi = xyzmh_ptmass(1,j) - yi = xyzmh_ptmass(2,j) - zi = xyzmh_ptmass(3,j) - mi = xyzmh_ptmass(4,j) + xi = xyzmh_ptmass(1,i) + yi = xyzmh_ptmass(2,i) + zi = xyzmh_ptmass(3,i) + mi = xyzmh_ptmass(4,i) do j=s_id,e_id if (i==j) cycle dx = xi - xyzmh_ptmass(1,j) @@ -528,34 +535,87 @@ subroutine get_force_TTL(xyzmh_ptmass,om,fxyz_ptmass,gtgrad,s_id,e_id) end subroutine get_force_TTL -subroutine initial_OM(xyzmh_ptmass,om,s_id,e_id) - real, intent(in) :: xyzmh_ptmass(:,:) - real, intent(out) :: om +subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,om,s_id,e_id,ismultiple,ds_init) + use utils_kepler, only :extract_a_dot,extract_a,Espec + real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass + real, intent(inout) :: fxyz_ptmass(:,:) + real, intent(out) :: om,ds_init + logical, intent(in) :: ismultiple integer, intent(in) :: s_id,e_id + real :: mi,mj,xi,yi,zi,dx,dy,dz,r2 + real :: vxi,vyi,vzi,dvx,dvy,dvz,v,rdotv,axi,ayi,azi,gravfi + real :: gravf,gtki + real :: Edot,E,semi,semidot integer :: i,j - real :: gtki,dx,dy,dz,xi,yi,zi,r1 + Edot = 0. + E = 0. om = 0. + do i=s_id,e_id + fxyz_ptmass(1,i) = 0. + fxyz_ptmass(2,i) = 0. + fxyz_ptmass(3,i) = 0. + enddo do i=s_id,e_id gtki = 0. + gravfi = 0. xi = xyzmh_ptmass(1,i) yi = xyzmh_ptmass(2,i) zi = xyzmh_ptmass(3,i) mi = xyzmh_ptmass(4,i) + vxi = vxyz_ptmass(1,i) + vyi = vxyz_ptmass(2,i) + vzi = vxyz_ptmass(3,i) do j=s_id,e_id - if (i == j) cycle + if (i==j) cycle dx = xi - xyzmh_ptmass(1,j) dy = yi - xyzmh_ptmass(2,j) dz = zi - xyzmh_ptmass(3,j) - r1 = 1./sqrt(dx**2+dy**2+dz**2) - gtki = gtki + xyzmh_ptmass(4,j)*r1 + dvx = vxi - vxyz_ptmass(1,j) + dvy = vyi - vxyz_ptmass(2,j) + dvz = vzi - vxyz_ptmass(3,j) + r2 = dx**2+dy**2+dz**3 + r = sqrt(r) + mj = xyzmh_ptmass(4,j) + gravf = xyzmh_ptmass(4,j)*(1./r2*r) + gtki = gtki + mj*(1./r) + fxyz_ptmass(1,i) = fxyz_ptmass(1,i) + dx*gravf + fxyz_ptmass(2,i) = fxyz_ptmass(2,i) + dy*gravf + fxyz_ptmass(3,i) = fxyz_ptmass(3,i) + dz*gravf + if (ismultiple) then + rdotv = dx*dvx + dy*dvy + dz*dvz + gravfi = gravfi + gravf*rdotv + else + v2 = dvx**2 + dvy**2 + dvz**2 + v = sqrt(v2) + endif + enddo om = om + gtki*mi + axi = fxyz_ptmass(1,i) + ayi = fxyz_ptmass(2,i) + azi = fxyz_ptmass(3,i) + acc = sqrt(axi**2 + ayi**2 + azi**2) + if (ismultiple) then + vi = sqrt(vxi**2 + vyi**2 + vzi**2) + Edot = Edot + mi*(vi*a - gravfi) + E = E + 0.5*mi*vi**2 - om + else + mu = mi*mj + call extract_a_dot(r2,r,mu,v2,v,acc,semidot) + call extract_a(r,mu,v2,semi) + endif enddo om = om*0.5 -end subroutine initial_OM + if (ismultiple) then + ds_init = eta_pert * (Edot/E) + else + ds_init = eta_pert * (semidot/semi) + endif + +end subroutine initial_int end module sdar_group diff --git a/src/main/utils_kepler.f90 b/src/main/utils_kepler.f90 index 4016871c7..661f3edf1 100644 --- a/src/main/utils_kepler.f90 +++ b/src/main/utils_kepler.f90 @@ -3,21 +3,29 @@ module utils_kepler implicit none contains -subroutine bindE(v2,r,mu,B) +subroutine Espec(v2,r,mu,B) real, intent(in) :: v2,r,mu real, intent(out) :: B B = 0.5*v2 - mu/r -end subroutine bindE +end subroutine Espec subroutine extract_a(r,mu,v2,aij) real, intent(in) :: r,mu,v2 real, intent(out):: aij - aij = (r*mu)/(2*mu-r*v2) + aij = (r*mu)/(2.*mu-r*v2) end subroutine extract_a +subroutine extract_a_dot(r2,r,mu,v2,v,acc,adot) + real, intent(in) :: r2,r,mu,v2,v,acc + real, intent(inout) :: adot + real :: mu2 + mu2 = mu**2 + adot = 2.*(mu2*v+r2*v*acc)/(2.*mu-r*v2)**2 +end subroutine extract_a_dot + subroutine extract_e(x,y,z,vx,vy,vz,mu,r,eij) real, intent(in) :: x,y,z,vx,vy,vz,mu,r real, intent(out):: eij From 72d695b843ea55b639289ee225c07b0ae3c8c109 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 8 Apr 2024 10:19:32 +1000 Subject: [PATCH 08/45] build the main step_extern sub for subsystems + adaption of sink_sink force... --- src/main/ptmass.F90 | 97 +++++++++++++-------- src/main/sdar_group.f90 | 21 ++--- src/main/step_extern.f90 | 176 ++++++++++++++++++++++++++++++++------- 3 files changed, 221 insertions(+), 73 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index dbee66a25..a39845103 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -265,7 +265,7 @@ end subroutine get_accel_sink_gas !+ !---------------------------------------------------------------- subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksink,& - iexternalforce,ti,merge_ij,merge_n,dsdt_ptmass) + iexternalforce,ti,merge_ij,merge_n,dsdt_ptmass,group_info) #ifdef FINVSQRT use fastmath, only:finvsqrt #endif @@ -273,14 +273,16 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin use extern_geopot, only:get_geopot_force use kernel, only:kernel_softening,radkern use vectorutils, only:unitvec - integer, intent(in) :: nptmass - real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) - real, intent(out) :: fxyz_ptmass(4,nptmass) - real, intent(out) :: phitot,dtsinksink - integer, intent(in) :: iexternalforce - real, intent(in) :: ti - integer, intent(out) :: merge_ij(:),merge_n - real, intent(out) :: dsdt_ptmass(3,nptmass) + use part, only:igarg,igcum + integer, intent(in) :: nptmass + real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) + real, intent(out) :: fxyz_ptmass(4,nptmass) + real, intent(out) :: phitot,dtsinksink + integer, intent(in) :: iexternalforce + real, intent(in) :: ti + integer, intent(out) :: merge_ij(:),merge_n + integer, optional, intent(in) :: group_info(:,:) + real, intent(out) :: dsdt_ptmass(3,nptmass) real :: xi,yi,zi,pmassi,pmassj,fxi,fyi,fzi,phii real :: ddr,dx,dy,dz,rr2,rr2j,dr3,f1,f2 real :: hsoft1,hsoft21,q2i,qi,psoft,fsoft @@ -288,7 +290,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin real :: fterm,pterm,potensoft0,dsx,dsy,dsz real :: J2i,rsinki,shati(3) real :: J2j,rsinkj,shatj(3) - integer :: i,j + integer :: k,l,i,j,start_id,end_id dtsinksink = huge(dtsinksink) fxyz_ptmass(:,:) = 0. @@ -313,7 +315,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !--compute N^2 forces on point mass particles due to each other ! !$omp parallel do default(none) & - !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,merge_ij,r_merge2,dsdt_ptmass) & + !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,merge_ij,r_merge2,dsdt_ptmass,group_info) & !$omp shared(iexternalforce,ti,h_soft_sinksink,potensoft0,hsoft1,hsoft21) & !$omp private(i,xi,yi,zi,pmassi,pmassj) & !$omp private(dx,dy,dz,rr2,rr2j,ddr,dr3,f1,f2) & @@ -323,7 +325,14 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !$omp private(fterm,pterm,J2i,J2j,shati,shatj,rsinki,rsinkj) & !$omp reduction(min:dtsinksink) & !$omp reduction(+:phitot,merge_n) - do i=1,nptmass + do k=1,nptmass + if (present(group_info)) then + start_id = group_info(igcum) + 1 + end_id = group_info(igcum) + i = group_info(igarg,k) + else + i = k + endif xi = xyzmh_ptmass(1,i) yi = xyzmh_ptmass(2,i) zi = xyzmh_ptmass(3,i) @@ -339,7 +348,13 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin dsx = 0. dsy = 0. dsz = 0. - do j=1,nptmass + do l=1,nptmass + if (present(group_info)) then + j = group_info(igarg,l) + if (j>=start_id .or. j<=end_id) cycle + else + j = l + endif if (i==j) cycle dx = xi - xyzmh_ptmass(1,j) dy = yi - xyzmh_ptmass(2,j) @@ -477,19 +492,19 @@ end subroutine get_accel_sink_sink !+ !---------------------------------------------------------------- subroutine get_gradf_sink_gas(nptmass,dt,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi, & - pmassi,fxyz_ptmass) + pmassi,fxyz_ptmass) use kernel, only:kernel_softening,kernel_gradsoftening,radkern - integer, intent(in) :: nptmass - real, intent(in) :: xi,yi,zi,hi,dt - real, intent(inout) :: fxi,fyi,fzi - real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) - real, intent(in) :: pmassi - real, intent(inout) :: fxyz_ptmass(4,nptmass) - real :: gtmpxi,gtmpyi,gtmpzi - real :: dx,dy,dz,rr2,ddr,dr3,g11,g12,g21,g22,pmassj - real :: dfx,dfy,dfz,drdotdf - real :: hsoft,hsoft1,hsoft21,q2i,qi,psoft,fsoft,gsoft,gpref - integer :: j + integer, intent(in) :: nptmass + real, intent(in) :: xi,yi,zi,hi,dt + real, intent(inout) :: fxi,fyi,fzi + real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) + real, intent(in) :: pmassi + real, intent(inout) :: fxyz_ptmass(4,nptmass) + real :: gtmpxi,gtmpyi,gtmpzi + real :: dx,dy,dz,rr2,ddr,dr3,g11,g12,g21,g22,pmassj + real :: dfx,dfy,dfz,drdotdf + real :: hsoft,hsoft1,hsoft21,q2i,qi,psoft,fsoft,gsoft,gpref + integer :: j gtmpxi = 0. ! use temporary summation variable gtmpyi = 0. ! (better for round-off, plus we need this bit of @@ -587,17 +602,18 @@ end subroutine get_gradf_sink_gas ! get gradient correction of the force for FSI integrator (sink-gas) !+ !---------------------------------------------------------------- -subroutine get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) +subroutine get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt,group_info) use kernel, only:kernel_softening,kernel_gradsoftening,radkern - integer, intent(in) :: nptmass - real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) - real, intent(inout) :: fxyz_ptmass(4,nptmass) - real, intent(in) :: dt + integer, intent(in) :: nptmass + real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) + real, intent(inout) :: fxyz_ptmass(4,nptmass) + real, intent(in) :: dt + integer, optional, intent(in) :: group_info(:,:) real :: xi,yi,zi,pmassi,pmassj,fxi,fyi,fzi,gxi,gyi,gzi real :: ddr,dx,dy,dz,dfx,dfy,dfz,drdotdf,rr2,dr3,g1,g2 real :: hsoft1,hsoft21,q2i,qi,psoft,fsoft,gsoft real :: gpref - integer :: i,j + integer :: i,j,k,l,start_id,end_id if (nptmass <= 1) return if (h_soft_sinksink > 0.) then @@ -611,13 +627,20 @@ subroutine get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) !--compute N^2 gradf on point mass particles due to each other ! !$omp parallel do default(none) & - !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass) & + !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,group_info) & !$omp shared(h_soft_sinksink,hsoft21,dt) & !$omp private(i,xi,yi,zi,pmassi,pmassj) & !$omp private(dx,dy,dz,dfx,dfy,dfz,drdotdf,rr2,ddr,dr3,g1,g2) & !$omp private(fxi,fyi,fzi,gxi,gyi,gzi,gpref) & !$omp private(q2i,qi,psoft,fsoft,gsoft) - do i=1,nptmass + do k=1,nptmass + if (present(group_info)) then + start_id = group_info(igcum) + 1 + end_id = group_info(igcum) + i = group_info(igarg,k) + else + i = k + endif xi = xyzmh_ptmass(1,i) yi = xyzmh_ptmass(2,i) zi = xyzmh_ptmass(3,i) @@ -629,7 +652,13 @@ subroutine get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) gxi = 0. gyi = 0. gzi = 0. - do j=1,nptmass + do l=1,nptmass + if (present(group_info)) then + j = group_info(igarg,l) + if (j>=start_id .or. j<=end_id) cycle + else + j = l + endif if (i==j) cycle dx = xi - xyzmh_ptmass(1,j) dy = yi - xyzmh_ptmass(2,j) diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index 92588763b..bb1e06fe2 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -25,11 +25,12 @@ module sdar_group ! Group identification routines ! !----------------------------------------------- -subroutine group_identify(nptmass,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) - real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) - integer, intent(in) :: group_info(:,:) - integer(kind=1), intent(inout) :: nmatrix(:,:) - integer, intent(in) :: nptmass +subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) + real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + integer, intent(in) :: group_info(:,:) + integer(kind=1), intent(inout) :: nmatrix(:,:) + integer, intent(inout) :: n_group,n_ingroup,n_sing + integer, intent(in) :: nptmass ngroup = 0 n_ingroup = 0 @@ -40,12 +41,13 @@ subroutine group_identify(nptmass,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) end subroutine group_identify -subroutine form_group(nmatrix,nptmass,group_info) - use part, only : igid,igcum +subroutine form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) + use part, only : igarg,igcum use dim, only : maxptmass integer(kind=1), intent(in) :: nmatrix(:,:) - integer, intent(out):: group_info(:,:) - integer, intent(in) :: nptmass + integer, intent(out) :: group_info(:,:) + integer, intent(in) :: nptmass + integer, intent(inout) :: n_group,n_ingroup,n_sing integer :: i,ncg logical :: visited(maxptmass) integer :: stack(maxptmass) @@ -348,7 +350,6 @@ subroutine backup_data(gsize,xyzmh_ptmass,vxyz_ptmass,bdata) bdata(j,i) = xyzmh_ptmass(j,i) bdata(j+ndim,i) =,vxyz_ptmass(j,i) enddo - !print*,bdata(1,:) enddo end subroutine backup_data diff --git a/src/main/step_extern.f90 b/src/main/step_extern.f90 index 9cb3da671..f22414871 100644 --- a/src/main/step_extern.f90 +++ b/src/main/step_extern.f90 @@ -39,6 +39,7 @@ module step_extern public :: step_extern_sph public :: step_extern_sph_gr public :: step_extern_FSI + public :: step_extern_subsys public :: step_extern_PEFRL contains @@ -509,9 +510,7 @@ subroutine step_extern_FSI(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fext,x integer, intent(in) :: npart,nptmass real, intent(inout) :: dtextforce real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) - real,parameter :: dk(3) = (/1./6.,2./3.,1./6./) - real,parameter :: ck(2) = (/0.5,0.5/) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) real :: dt,t_end_step,dtextforce_min real :: pmassi,timei logical :: done,last_step @@ -583,19 +582,122 @@ subroutine step_extern_FSI(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fext,x end subroutine step_extern_FSI + !---------------------------------------------------------------- + !+ + ! This is the equivalent of the routine below with no cooling + ! and external forces except ptmass with subsystems algorithms.. + !+ + !---------------------------------------------------------------- +subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass, & + dsdt_ptmass,gtgrad,group_info,n_group,n_ingroup,n_sing) + use part, only: isdead_or_accreted,igas,massoftype + use io, only:iverbose,id,master,iprint,warning,fatal + use io_summary, only:summary_variable,iosumextr,iosumextt + use sdar_group, only:group_identify,evolve_groups + real, intent(in) :: dtsph,time + integer, intent(in) :: npart,nptmass + real, intent(inout) :: dtextforce + real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:),gtgrad(:,:) + integer, intent(inout) :: group_info(:,:) + integer, intent(inout) :: n_ingroup,n_group,n_sing + real,parameter :: dk(3) = (/1./6.,2./3.,1./6./) + real,parameter :: ck(2) = (/0.5,0.5/) + real :: dt,t_end_step,dtextforce_min + real :: pmassi,timei + logical :: done,last_step + integer :: nsubsteps + + ! + ! determine whether or not to use substepping + ! + if (dtextforce < dtsph) then + dt = dtextforce + last_step = .false. + else + dt = dtsph + last_step = .true. + endif + + timei = time + pmassi = massoftype(igas) + t_end_step = timei + dtsph + nsubsteps = 0 + dtextforce_min = huge(dt) + done = .false. + + substeps: do while (timei <= t_end_step .and. .not.done) + timei = timei + dt + if (abs(dt) < tiny(0.)) call fatal('step_extern','dt <= 0 in sink-gas substepping',var='dt',val=dt) + nsubsteps = nsubsteps + 1 + ! + ! Group all the ptmass in the system in multiple small group for regularization + ! + call group_identify(nptmass,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) + + call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fext, & + xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,group_info) + call kick_4th (dk(1),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + call drift_4th(ck(1),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup) + call evolve_groups(n_group,timei,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fext, & + xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,group_info) ! Direct calculation of the force and force gradient + call get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,group_info) + call kick_4th (dk(2),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + call drift_4th(ck(2),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup) + call evolve_groups(n_group,timei,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fext, & + xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,group_info) + call kick_4th (dk(3),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + if (iverbose >= 2 ) write(iprint,*) "nsubsteps : ",nsubsteps,"time,dt : ",timei,dt + + dtextforce_min = min(dtextforce_min,dtextforce) + + if (last_step) then + done = .true. + else + dt = dtextforce + if (timei + dt > t_end_step) then + dt = t_end_step - timei + last_step = .true. + endif + endif + enddo substeps + + if (nsubsteps > 1) then + if (iverbose>=1 .and. id==master) then + write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & + ' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph + endif + call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) + call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) + endif + + +end subroutine step_extern_subsys + + + + !---------------------------------------------------------------- !+ ! drift routine for the 4th order scheme !+ !---------------------------------------------------------------- -subroutine drift_4th(ck,dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass) +subroutine drift_4th(ck,dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup) use part, only: isdead_or_accreted,ispinx,ispiny,ispinz - real, intent(in) :: dt,ck - integer, intent(in) :: npart,nptmass - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),dsdt_ptmass(:,:) - integer :: i + real, intent(in) :: dt,ck + integer, intent(in) :: npart,nptmass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),dsdt_ptmass(:,:) + integer, optional, intent(in) :: n_ingroup + integer :: i,istart_ptmass + + istart_ptmass = 1 + if (present(n_ingroup)) istart_ptmass = n_ingroup + 1 + + ! Drift gas particles @@ -616,7 +718,7 @@ subroutine drift_4th(ck,dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsd !$omp parallel do default(none) & !$omp shared(nptmass,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass,ck,dt) & !$omp private(i) - do i=1,nptmass + do i=istart_ptmass,nptmass if (xyzmh_ptmass(4,i) > 0.) then xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + ck*dt*vxyz_ptmass(1,i) xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + ck*dt*vxyz_ptmass(2,i) @@ -684,18 +786,19 @@ end subroutine kick_4th !+ !---------------------------------------------------------------- -subroutine get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) - use options, only:iexternalforce +subroutine get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,group_info) + use options, only:iexternalforce,use_regnbody use dim, only:maxptmass use io, only:iverbose,master,iprint,warning,fatal use part, only:epot_sinksink,fxyz_ptmass_sinksink,dsdt_ptmass_sinksink use ptmass, only:get_accel_sink_gas,get_accel_sink_sink,merge_sinks use timestep, only:bignumber,C_force - integer, intent(in):: nptmass,npart,nsubsteps - real, intent(inout) :: xyzh(:,:),fext(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) - real, intent(inout) :: dtextforce - real, intent(in) :: timei,pmassi + integer, intent(in) :: nptmass,npart,nsubsteps + real, intent(inout) :: xyzh(:,:),fext(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) + real, intent(inout) :: dtextforce + real, intent(in) :: timei,pmassi + integer, optional,intent(in) :: group_info(:,:) integer :: merge_ij(nptmass) integer :: merge_n integer :: i @@ -708,12 +811,22 @@ subroutine get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fe dtphi2 = bignumber fonrmax = 0 if (nptmass>0) then - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) - if (merge_n > 0) then - call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + if (use_regnbody) then + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,group_info) + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,group_info) + endif + else call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) + endif endif else fxyz_ptmass(:,:) = 0. @@ -763,21 +876,26 @@ end subroutine get_force_4th !---------------------------------------------------------------- -subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass) +subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,group_info) use dim, only:maxptmass use ptmass, only:get_gradf_sink_gas,get_gradf_sink_sink - integer, intent(in) :: nptmass,npart - real, intent(inout) :: xyzh(:,:),fext(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),fxyz_ptmass(4,nptmass) - real, intent(inout) :: dt - real, intent(in) :: pmassi + use options, only:use_regnbody + integer, intent(in) :: nptmass,npart + real, intent(inout) :: xyzh(:,:),fext(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),fxyz_ptmass(:,:) + real, intent(inout) :: dt + real, intent(in) :: pmassi + integer, optional, intent(in) :: group_info(:,:) real :: fextx,fexty,fextz integer :: i if (nptmass>0) then - call get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) - !print*,fxyz_ptmass(1,1:5) + if(use_regnbody) then + call get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt,group_info) + else + call get_gradf_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,dt) + endif else fxyz_ptmass(:,:) = 0. endif From 11e0a27d947abc774013ab1b3322e1f8ab59036b Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 8 Apr 2024 14:40:20 +1000 Subject: [PATCH 09/45] fix some oversights --- src/main/sdar_group.f90 | 12 +++++++----- src/main/step_extern.f90 | 20 +++++++++++++------- src/main/step_leapfrog.F90 | 10 ++++++++-- 3 files changed, 28 insertions(+), 14 deletions(-) diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index bb1e06fe2..c83dfc566 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -36,7 +36,7 @@ subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptm n_ingroup = 0 n_sing = 0 call matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) - call form_group(group_info,nmatrix,nptmass) + call form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) end subroutine group_identify @@ -109,13 +109,16 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) real :: dx,dy,dz,dvx,dvy,dvz,r2,r,v2,mu real :: aij,eij,B,rperi integer :: i,j +! +!!TODO MPI Proof version of the matrix construction +! !$omp parallel do default(none) & !$omp shared(nptmass,r_neigh,C_bin,t_crit,nmatrix) & !$omp private(xi,yi,zi,mi,vxi,vyi,vzi,i,j) & !$omp private(dx,dy,dz,r,r2) & !$omp private(dvx,dvy,dvz,v2) & - !$omp private(mu,aij,eij,B,r_peri) & + !$omp private(mu,aij,eij,B,r_peri) do i=1,nptmass xi = xyzmh_ptmass(1,i) yi = xyzmh_ptmass(2,i) @@ -497,6 +500,8 @@ subroutine get_force_TTL(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,s_id,e_id) real :: gravf,gtki integer :: i,j om = 0. + + do i=s_id,e_id fxyz_ptmass(1,i) = 0. fxyz_ptmass(2,i) = 0. @@ -504,9 +509,6 @@ subroutine get_force_TTL(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,s_id,e_id) gtgrad(1,i) = 0. gtgrad(2,i) = 0. gtgrad(3,i) = 0. - enddo - - do i=s_id,e_id gtki = 0. xi = xyzmh_ptmass(1,i) yi = xyzmh_ptmass(2,i) diff --git a/src/main/step_extern.f90 b/src/main/step_extern.f90 index eb9c22ed8..718281e2d 100644 --- a/src/main/step_extern.f90 +++ b/src/main/step_extern.f90 @@ -638,7 +638,7 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex ! ! Group all the ptmass in the system in multiple small group for regularization ! - call group_identify(nptmass,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) + call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fext, & xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,group_info) @@ -649,8 +649,8 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,group_info) ! Direct calculation of the force and force gradient call get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,group_info) call kick_4th (dk(2),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - call drift_4th(ck(2),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup) call evolve_groups(n_group,timei,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + call drift_4th(ck(2),dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup) call get_force_4th(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fext, & xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,group_info) call kick_4th (dk(3),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) @@ -690,8 +690,8 @@ end subroutine step_extern_subsys !+ !---------------------------------------------------------------- -subroutine drift_4th(ck,dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup) - use part, only: isdead_or_accreted,ispinx,ispiny,ispinz +subroutine drift_4th(ck,dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup,group_info) + use part, only: isdead_or_accreted,ispinx,ispiny,ispinz,igarg use io , only:id,master use mpiutils, only:bcast_mpi real, intent(in) :: dt,ck @@ -699,7 +699,8 @@ subroutine drift_4th(ck,dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsd real, intent(inout) :: xyzh(:,:),vxyzu(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),dsdt_ptmass(:,:) integer, optional, intent(in) :: n_ingroup - integer :: i,istart_ptmass + integer, optional, intent(in) :: group_info(:,:) + integer :: i,k,istart_ptmass istart_ptmass = 1 if (present(n_ingroup)) istart_ptmass = n_ingroup + 1 @@ -723,8 +724,13 @@ subroutine drift_4th(ck,dt,npart,nptmass,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsd if(id==master) then !$omp parallel do default(none) & !$omp shared(nptmass,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass,ck,dt) & - !$omp private(i) - do i=istart_ptmass,nptmass + !$omp private(i,k) + do k=istart_ptmass,nptmass + if (present(n_ingroup)) then + i = group_info(igarg,k) + else + i = k + endif if (xyzmh_ptmass(4,i) > 0.) then xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + ck*dt*vxyz_ptmass(1,i) xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + ck*dt*vxyz_ptmass(2,i) diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 18d197625..53a77c316 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -104,6 +104,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use timestep, only:dterr,bignumber,tolv use mpiutils, only:reduceall_mpi use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,ibin_wake + use part, only:n_group,n_ingroup,n_sing,gtgrad,group_info use io_summary, only:summary_printout,summary_variable,iosumtvi,iowake, & iosumflrp,iosumflrps,iosumflrc use boundary_dyn, only:dynamic_bdy,update_xyzminmax @@ -121,8 +122,9 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use damping, only:idamp use cons2primsolver, only:conservative2primitive,primitive2conservative use eos, only:equationofstate - use step_extern, only:step_extern_FSI,step_extern_PEFRL,step_extern_lf, & - step_extern_gr,step_extern_sph_gr,step_extern_sph + use step_extern, only:step_extern_FSI,step_extern_PEFRL,step_extern_lf, & + step_extern_gr,step_extern_sph_gr,step_extern_sph, & + step_extern_subsys integer, intent(inout) :: npart integer, intent(in) :: nactive @@ -238,6 +240,10 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (use_fourthorder) then call step_extern_FSI(dtextforce,dtsph,t,npart,nptmass,xyzh,vxyzu,fext, & xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass) + elseif(use_regnbody) then + call step_extern_subsys(dtextforce,dtsph,t,npart,nptmass,xyzh,vxyzu,fext, & + xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass, & + gtgrad,group_info,n_group,n_ingroup,n_sing) else call step_extern(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,t, & nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,nbinmax,ibin_wake) From 1ef7a43a57abed85355beb3d17389a936ae3dd41 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 10 Apr 2024 14:16:36 +1000 Subject: [PATCH 10/45] setp extern switch to .F90 --- src/main/{step_extern.f90 => step_extern.F90} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename src/main/{step_extern.f90 => step_extern.F90} (100%) diff --git a/src/main/step_extern.f90 b/src/main/step_extern.F90 similarity index 100% rename from src/main/step_extern.f90 rename to src/main/step_extern.F90 From 8c18418e8361f5da71a71d7eaa96b38d6434a70d Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 10 Apr 2024 14:45:47 +1000 Subject: [PATCH 11/45] fix subsystem flag --- src/main/ptmass.F90 | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 1bb20e6f6..2960a8705 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -65,10 +65,11 @@ module ptmass real, public :: f_acc = 0.8 real, public :: h_soft_sinkgas = 0.0 real, public :: h_soft_sinksink = 0.0 - real, public :: r_merge_uncond = 0.0 ! sinks will unconditionally merge if they touch - real, public :: r_merge_cond = 0.0 ! sinks will merge if bound within this radius - real, public :: f_crit_override = 0.0 ! 1000. - logical, public :: use_fourthorder = .false. + real, public :: r_merge_uncond = 0.0 ! sinks will unconditionally merge if they touch + real, public :: r_merge_cond = 0.0 ! sinks will merge if bound within this radius + real, public :: f_crit_override = 0.0 ! 1000. + logical, public :: use_fourthorder = .false. ! FSI switch + logical, public :: use_regnbody = .false. ! subsystems switch ! Note for above: if f_crit_override > 0, then will unconditionally make a sink when rho > f_crit_override*rho_crit_cgs ! This is a dangerous parameter since failure to form a sink might be indicative of another problem. ! This is a hard-coded parameter due to this danger, but will appear in the .in file if set > 0. @@ -2135,6 +2136,7 @@ subroutine write_options_ptmass(iunit) call write_inopt(r_merge_uncond,'r_merge_uncond','sinks will unconditionally merge within this separation',iunit) call write_inopt(r_merge_cond,'r_merge_cond','sinks will merge if bound within this radius',iunit) call write_inopt(use_fourthorder, 'use_fourthorder', 'FSI integration method (4th order)', iunit) + call write_inopt(use_regnbody, 'use_regnboby', 'Subsystem (SD and secular and AR) integration method', iunit) end subroutine write_options_ptmass @@ -2211,6 +2213,8 @@ subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) ngot = ngot + 1 case('use_fourthorder') read(valstring,*,iostat=ierr) use_fourthorder + case('use_regnbody') + read(valstring,*,iostat=ierr) use_regnbody case default imatch = .false. end select From ce4d08f6cbc3e13995d4901056aafdc3dac2dda6 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 10 Apr 2024 16:34:09 +1000 Subject: [PATCH 12/45] first compilation --- build/Makefile | 1 + src/main/options.f90 | 6 - src/main/part.F90 | 2 +- src/main/ptmass.F90 | 17 +-- src/main/sdar_group.f90 | 232 ++++++++++++++++++++----------------- src/main/step_extern.F90 | 34 +++--- src/main/step_leapfrog.F90 | 4 +- 7 files changed, 160 insertions(+), 136 deletions(-) diff --git a/build/Makefile b/build/Makefile index 3de3e2347..ef6f571b8 100644 --- a/build/Makefile +++ b/build/Makefile @@ -535,6 +535,7 @@ SOURCES= physcon.f90 ${CONFIG} ${SRCKERNEL} io.F90 units.f90 \ utils_deriv.f90 utils_implicit.f90 radiation_implicit.f90 ${SRCTURB} \ ${SRCINJECT_DEPS} wind_equations.f90 wind.F90 ${SRCINJECT} \ ${SRCKROME} memory.f90 ${SRCREADWRITE_DUMPS} \ + utils_sdar.f90 utils_kepler.f90 sdar_group.f90\ quitdump.f90 ptmass.F90 \ readwrite_infile.F90 dens.F90 force.F90 deriv.F90 energies.F90 sort_particles.f90 \ utils_shuffleparticles.F90 evwrite.f90 step_extern.F90 step_leapfrog.F90 writeheader.F90 ${SRCAN} step_supertimestep.F90 \ diff --git a/src/main/options.f90 b/src/main/options.f90 index be508498a..36bc7e5eb 100644 --- a/src/main/options.f90 +++ b/src/main/options.f90 @@ -170,12 +170,6 @@ subroutine set_default_options ! variable composition use_var_comp = .false. - <<<<<<< HEAD - use_fourthorder = .false. - use_regnbody = .false. - - ======= - >>>>>>> 4thorder_scheme end subroutine set_default_options end module options diff --git a/src/main/part.F90 b/src/main/part.F90 index c1078db6c..f81e934fc 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -296,7 +296,7 @@ module part integer, parameter :: igarg = 1 ! idx of the particle member of a group integer, parameter :: igcum = 2 ! cumulative sum of the indices to find the starting and ending point of a group ! needed for group identification and sorting - integer :: ngroup = 0 + integer :: n_group = 0 integer :: n_ingroup = 0 integer :: n_sing = 0 ! Gradient of the time transformation function diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 2960a8705..1aa9b797d 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -345,7 +345,8 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,merge_ij,r_merge2,dsdt_ptmass,group_info) & !$omp shared(iexternalforce,ti,h_soft_sinksink,potensoft0,hsoft1,hsoft21) & !$omp shared(extrapfac,extrap,fsink_old) & - !$omp private(i,xi,yi,zi,pmassi,pmassj) & + !$omp private(i,j,xi,yi,zi,pmassi,pmassj) & + !$omp private(start_id,end_id) & !$omp private(dx,dy,dz,rr2,rr2j,ddr,dr3,f1,f2) & !$omp private(fxi,fyi,fzi,phii,dsx,dsy,dsz) & !$omp private(fextx,fexty,fextz,phiext) & @@ -355,8 +356,8 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !$omp reduction(+:phitot,merge_n) do k=1,nptmass if (present(group_info)) then - start_id = group_info(igcum) + 1 - end_id = group_info(igcum) + start_id = group_info(igcum,k) + 1 + end_id = group_info(igcum,k) i = group_info(igarg,k) else i = k @@ -644,7 +645,8 @@ end subroutine get_gradf_sink_gas !+ !---------------------------------------------------------------- subroutine get_gradf_sink_sink(nptmass,dt,xyzmh_ptmass,fxyz_ptmass,fsink_old,group_info) - use kernel, only:kernel_softening,kernel_grad_soft,radkern + use kernel, only:kernel_softening,kernel_grad_soft,radkern + use part, only:igarg,igcum integer, intent(in) :: nptmass real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(inout) :: fxyz_ptmass(4,nptmass) @@ -671,14 +673,15 @@ subroutine get_gradf_sink_sink(nptmass,dt,xyzmh_ptmass,fxyz_ptmass,fsink_old,gro !$omp parallel do default(none) & !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,fsink_old,group_info) & !$omp shared(h_soft_sinksink,hsoft21,dt) & - !$omp private(i,xi,yi,zi,pmassi,pmassj) & + !$omp private(i,j,xi,yi,zi,pmassi,pmassj) & + !$omp private(start_id,end_id) & !$omp private(dx,dy,dz,dfx,dfy,dfz,drdotdf,rr2,ddr,dr3,g1,g2) & !$omp private(fxi,fyi,fzi,gxi,gyi,gzi,gpref) & !$omp private(q2i,qi,psoft,fsoft,gsoft) do k=1,nptmass if (present(group_info)) then - start_id = group_info(igcum) + 1 - end_id = group_info(igcum) + start_id = group_info(igcum,k) + 1 + end_id = group_info(igcum,k) i = group_info(igarg,k) else i = k diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index c83dfc566..b7c2eaa38 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -5,18 +5,20 @@ module sdar_group ! ! :References: Makino et Aarseth 2002,Wang et al. 2020, Wang et al. 2021, Rantala et al. 2023 ! -! :Owner: Daniel Price +! :Owner: Yann BERNARD ! use utils_sdar implicit none public :: group_identify public :: evolve_groups ! parameters for group identification - real, public :: r_neigh = 0.0 - real, public :: t_crit = 0.0 - real, public :: C_bin = 0.0 - real, public :: r_search = 0.0 real, parameter :: eta_pert = 0.02 + real, parameter :: time_error = 1e-10 + real, parameter :: max_step = 100000 + real, parameter, public :: r_neigh = 0.001 + real, public :: t_crit = 0.0 + real, public :: C_bin = 0.02 + real, public :: r_search = 100.*r_neigh private contains @@ -27,12 +29,12 @@ module sdar_group !----------------------------------------------- subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) - integer, intent(in) :: group_info(:,:) + integer, intent(inout) :: group_info(:,:) integer(kind=1), intent(inout) :: nmatrix(:,:) integer, intent(inout) :: n_group,n_ingroup,n_sing integer, intent(in) :: nptmass - ngroup = 0 + n_group = 0 n_ingroup = 0 n_sing = 0 call matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) @@ -54,10 +56,10 @@ subroutine form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) do i=1,nptmass if(.not.visited(i)) then n_ingroup = n_ingroup + 1 - call dfs(i,i,visited,stack,group_info,nmatrix,nptmass,n_ingroup,ncg) + call dfs(i,visited,stack,group_info,nmatrix,nptmass,n_ingroup,ncg) if (ncg>1)then - ngroup = ngroup + 1 - group_info(igcum,ngroup+1) = ncg + group_info(igcum,ngroup) + n_group = n_group + 1 + group_info(igcum,n_group+1) = ncg + group_info(igcum,n_group) else n_ingroup = n_ingroup - 1 group_info(igarg,nptmass-n_sing) = i @@ -67,18 +69,19 @@ subroutine form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) enddo end subroutine form_group -subroutine dfs(inode,iroot,visited,stack,group_info,nmatrix,nptmass,n_ingroup,ncg) +subroutine dfs(iroot,visited,stack,group_info,nmatrix,nptmass,n_ingroup,ncg) use part, only : igarg - integer, intent(in) :: inode,nptmass,iroot + integer, intent(in) :: nptmass,iroot integer, intent(out) :: ncg integer(kind=1), intent(in) :: nmatrix(:,:) integer, intent(inout) :: group_info(:,:) integer, intent(inout) :: n_ingroup integer, intent(out) :: stack(:) logical, intent(inout) :: visited(:) - integer :: j,stack_top + integer :: j,stack_top,inode ncg = 1 + inode = iroot group_info(igarg,n_ingroup) = inode stack_top = stack_top + 1 stack(stack_top) = inode @@ -114,11 +117,12 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) ! !$omp parallel do default(none) & - !$omp shared(nptmass,r_neigh,C_bin,t_crit,nmatrix) & + !$omp shared(nptmass,C_bin,t_crit,nmatrix) & + !$omp shared(xyzmh_ptmass,vxyz_ptmass,r_search) & !$omp private(xi,yi,zi,mi,vxi,vyi,vzi,i,j) & !$omp private(dx,dy,dz,r,r2) & !$omp private(dvx,dvy,dvz,v2) & - !$omp private(mu,aij,eij,B,r_peri) + !$omp private(mu,aij,eij,B,rperi) do i=1,nptmass xi = xyzmh_ptmass(1,i) yi = xyzmh_ptmass(2,i) @@ -171,7 +175,7 @@ end subroutine matrix_construction !--------------------------------------------- subroutine evolve_groups(n_group,tnext,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) - use part, only: igid,igarg,igsize,igcum + use part, only: igarg,igcum real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),gtgrad(:,:) integer, intent(in) :: group_info(:,:) integer, intent(inout) :: n_group @@ -179,14 +183,15 @@ subroutine evolve_groups(n_group,tnext,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ integer :: i,start_id,end_id,gsize !$omp parallel do default(none)& !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass)& - !$omp shared(tnext)& - !$omp private(i,start_id,end_id,gsize)& + !$omp shared(tnext,group_info,gtgrad)& + !$omp private(i,start_id,end_id,gsize) do i=1,n_group start_id = group_info(igcum,i) + 1 end_id = group_info(igcum,i+1) gsize = end_id - start_id call integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) enddo + !$omp end parallel do end subroutine evolve_groups @@ -196,11 +201,13 @@ subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmas fxyz_ptmass(:,:),gtgrad(:,:) integer, intent(in) :: start_id,end_id,gsize real, intent(in) :: tnext + real, allocatable :: bdata(:) real :: ds(2) - real :: timetable(ck_size) + real :: time_table(ck_size) integer :: switch integer :: step_count_int,step_count_tsyn,n_step_end real :: dt,ds_init,dt_end,step_modif,t_old,W_old + real :: W,tcoord logical :: t_end_flag,backup_flag,ismultiple integer :: i @@ -209,7 +216,9 @@ subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmas ismultiple = gsize > 2 - call initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,om,s_id,e_id,ismultiple,ds_init) + call initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,W,start_id,end_id,ismultiple,ds_init) + + allocate(bdata(gsize*9)) step_count_int = 0 step_count_tsyn = 0 @@ -222,23 +231,20 @@ subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmas do while (.true.) if (backup_flag) then - call backup_data(gsize,xyzmh_ptmass,vxyz_ptmass,bdata) + call backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,bdata) else - call restore_state(gsize,xyzmh_ptmass,vxyz_ptmass,tcoord,t_old,W,W_old,bdata) + call restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,tcoord,t_old,W,W_old,bdata) endif t_old = tcoord W_old = W if (gsize>1) then do i=1,ck_size - call drift_TTL (gsize,xyzmh_ptmass,vxyz_ptmass,ds(switch)*ck(i), & - tcoord,W,start_id,end_id) + call drift_TTL (tcoord,W,ds(switch)*ck(i),xyzmh_ptmass,vxyz_ptmass,start_id,end_id) time_table(i) = tcoord - call kick_TTL (gsize,xyzmh_ptmass,vxyz_ptmass,fxyz,gtgrad, & - ds(switch)*dk(i),W,om,start_id,end_id) + call kick_TTL (ds(switch)*dk(i),W,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,start_id,end_id) enddo else - call oneStep_bin(gsize,xyzmh_ptmass,vxyz_ptmass,fxyz,gtgrad, & - ds(switch),tcoord,W,om,time_table,start_id,end_id) + call oneStep_bin(tcoord,W,ds(switch),xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,time_table,start_id,end_id) endif dt = tcoord - t_old @@ -295,6 +301,8 @@ subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmas endif enddo + deallocate(bdata) + end subroutine integrate_to_time @@ -320,7 +328,7 @@ subroutine new_ds_sync_sup(ds,time_table,tnext,switch) real, intent(in) :: tnext integer, intent(in) :: switch integer :: i,k - real :: tp,dtk,dstmp + real :: tp,dtc,dstmp do i=1,ck_size k = cck_sorted_id(i) if(tnext 0) then call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,group_info) + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,group_info=group_info) endif else call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 62b0ed4f6..b8f2d249d 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -105,7 +105,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use timestep, only:dterr,bignumber,tolv use mpiutils, only:reduceall_mpi use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,fsink_old,ibin_wake - use part, only:n_group,n_ingroup,n_sing,gtgrad,group_info + use part, only:n_group,n_ingroup,n_sing,gtgrad,group_info,nmatrix use io_summary, only:summary_printout,summary_variable,iosumtvi,iowake, & iosumflrp,iosumflrps,iosumflrc use boundary_dyn, only:dynamic_bdy,update_xyzminmax @@ -256,7 +256,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) elseif(use_regnbody) then call step_extern_subsys(dtextforce,dtsph,t,npart,nptmass,xyzh,vxyzu,fext, & xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass, & - fsink_old,gtgrad,group_info,n_group,n_ingroup,n_sing) + fsink_old,gtgrad,group_info,nmatrix,n_group,n_ingroup,n_sing) else call step_extern_lf(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,fext,fxyzu,t, & nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,nbinmax,ibin_wake) From aaff1cb07293e9d10fb36a406aa03a6bf1b9fd91 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 10 Apr 2024 16:52:29 +1000 Subject: [PATCH 13/45] fix typo --- src/main/ptmass.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 1aa9b797d..ec5b1f2fd 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -2139,7 +2139,7 @@ subroutine write_options_ptmass(iunit) call write_inopt(r_merge_uncond,'r_merge_uncond','sinks will unconditionally merge within this separation',iunit) call write_inopt(r_merge_cond,'r_merge_cond','sinks will merge if bound within this radius',iunit) call write_inopt(use_fourthorder, 'use_fourthorder', 'FSI integration method (4th order)', iunit) - call write_inopt(use_regnbody, 'use_regnboby', 'Subsystem (SD and secular and AR) integration method', iunit) + call write_inopt(use_regnbody, 'use_regnbody', 'Subsystem (SD and secular and AR) integration method', iunit) end subroutine write_options_ptmass From e932154a29c35cb5786c13eedd15edf3e37f2e4a Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 10 Apr 2024 17:15:02 +1000 Subject: [PATCH 14/45] fix group detection... --- src/main/sdar_group.f90 | 39 +++++++++++++++++++++++---------------- 1 file changed, 23 insertions(+), 16 deletions(-) diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index b7c2eaa38..049b8130f 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -28,6 +28,7 @@ module sdar_group ! !----------------------------------------------- subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) + use io ,only:id,master,iverbose,iprint real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) integer, intent(inout) :: group_info(:,:) integer(kind=1), intent(inout) :: nmatrix(:,:) @@ -37,26 +38,31 @@ subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptm n_group = 0 n_ingroup = 0 n_sing = 0 + call matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) call form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) + if (id==master .and. iverbose>1) then + write(iprint,"(i6,a,i6,a,i6,a)") n_group," groups identified, ",n_ingroup," in a group, ",n_sing," singles..." + endif + end subroutine group_identify subroutine form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) use part, only : igarg,igcum - use dim, only : maxptmass - integer(kind=1), intent(in) :: nmatrix(:,:) - integer, intent(out) :: group_info(:,:) - integer, intent(in) :: nptmass - integer, intent(inout) :: n_group,n_ingroup,n_sing + integer, intent(in) :: nptmass + integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) + integer, intent(inout) :: group_info(2,nptmass) + integer, intent(inout) :: n_group,n_ingroup,n_sing integer :: i,ncg - logical :: visited(maxptmass) - integer :: stack(maxptmass) + logical :: visited(nptmass) + visited = .false. + group_info(igcum,1) = 1 do i=1,nptmass if(.not.visited(i)) then n_ingroup = n_ingroup + 1 - call dfs(i,visited,stack,group_info,nmatrix,nptmass,n_ingroup,ncg) + call dfs(i,visited,group_info,nmatrix,nptmass,n_ingroup,ncg) if (ncg>1)then n_group = n_group + 1 group_info(igcum,n_group+1) = ncg + group_info(igcum,n_group) @@ -69,15 +75,15 @@ subroutine form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) enddo end subroutine form_group -subroutine dfs(iroot,visited,stack,group_info,nmatrix,nptmass,n_ingroup,ncg) +subroutine dfs(iroot,visited,group_info,nmatrix,nptmass,n_ingroup,ncg) use part, only : igarg - integer, intent(in) :: nptmass,iroot - integer, intent(out) :: ncg - integer(kind=1), intent(in) :: nmatrix(:,:) - integer, intent(inout) :: group_info(:,:) - integer, intent(inout) :: n_ingroup - integer, intent(out) :: stack(:) - logical, intent(inout) :: visited(:) + integer, intent(in) :: nptmass,iroot + integer, intent(out) :: ncg + integer(kind=1), intent(in) :: nmatrix(nptmass,nptmass) + integer, intent(inout) :: group_info(2,nptmass) + integer, intent(inout) :: n_ingroup + logical, intent(inout) :: visited(nptmass) + integer :: stack(nptmass) integer :: j,stack_top,inode ncg = 1 @@ -92,6 +98,7 @@ subroutine dfs(iroot,visited,stack,group_info,nmatrix,nptmass,n_ingroup,ncg) do j= 1,nptmass if (nmatrix(inode,j)==1 .and. .not.(visited(j))) then n_ingroup = n_ingroup + 1 + ncg = ncg + 1 stack_top = stack_top + 1 stack(stack_top) = j visited(j) = .true. From 72c6093d1335deb97782a092c772941711b4014e Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 15 Apr 2024 11:56:49 +1000 Subject: [PATCH 15/45] fix group_info to handle correctly only external forces --- src/main/part.F90 | 3 +- src/main/ptmass.F90 | 55 ++++--- src/main/sdar_group.f90 | 328 +++++++++++++++++++++++--------------- src/main/step_extern.F90 | 4 +- src/main/utils_kepler.f90 | 4 +- 5 files changed, 235 insertions(+), 159 deletions(-) diff --git a/src/main/part.F90 b/src/main/part.F90 index 2f124e91d..f9c026ddd 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -297,6 +297,7 @@ module part integer(kind=1), allocatable :: nmatrix(:,:) integer, parameter :: igarg = 1 ! idx of the particle member of a group integer, parameter :: igcum = 2 ! cumulative sum of the indices to find the starting and ending point of a group + integer, parameter :: igid = 3 ! id of the group, correspond to the root of the group in the dfs/union find construction ! needed for group identification and sorting integer :: n_group = 0 integer :: n_ingroup = 0 @@ -493,7 +494,7 @@ subroutine allocate_part call allocate_array('abundance', abundance, nabundances, maxp_h2) endif call allocate_array('T_gas_cool', T_gas_cool, maxp_krome) - call allocate_array('group_info', group_info, 2, maxptmass) + call allocate_array('group_info', group_info, 3, maxptmass) call allocate_array("nmatrix", nmatrix, maxptmass, maxptmass) call allocate_array("gtgrad", gtgrad, 3, maxptmass) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 259ae0a23..33853473f 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -299,7 +299,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin use extern_geopot, only:get_geopot_force use kernel, only:kernel_softening,radkern use vectorutils, only:unitvec - use part, only:igarg,igcum + use part, only:igarg,igid integer, intent(in) :: nptmass real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(out) :: fxyz_ptmass(4,nptmass) @@ -307,7 +307,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin integer, intent(in) :: iexternalforce real, intent(in) :: ti integer, intent(out) :: merge_ij(:),merge_n - integer, optional, intent(in) :: group_info(:,:) + integer, optional, intent(in) :: group_info(3,nptmass) real, intent(out) :: dsdt_ptmass(3,nptmass) real, optional, intent(in) :: extrapfac real, optional, intent(in) :: fsink_old(4,nptmass) @@ -318,8 +318,8 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin real :: fterm,pterm,potensoft0,dsx,dsy,dsz real :: J2i,rsinki,shati(3) real :: J2j,rsinkj,shatj(3) - integer :: k,l,i,j,start_id,end_id - logical :: extrap,wsub + integer :: k,l,i,j,gidi,gidj + logical :: extrap,subsys dtsinksink = huge(dtsinksink) fxyz_ptmass(:,:) = 0. @@ -335,11 +335,11 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin extrap = .false. endif - if(present(group_info)) then - wsub = .true. - extrap = .false. + if (present(group_info)) then + subsys = .true. + else + subsys = .false. endif - ! !--get self-contribution to the potential if sink-sink softening is used ! @@ -356,11 +356,11 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !--compute N^2 forces on point mass particles due to each other ! !$omp parallel do default(none) & - !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,merge_ij,r_merge2,dsdt_ptmass,group_info) & + !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,merge_ij,r_merge2,dsdt_ptmass,group_info,subsys) & !$omp shared(iexternalforce,ti,h_soft_sinksink,potensoft0,hsoft1,hsoft21) & !$omp shared(extrapfac,extrap,fsink_old) & !$omp private(i,j,xi,yi,zi,pmassi,pmassj) & - !$omp private(start_id,end_id) & + !$omp private(gidi,gidj) & !$omp private(dx,dy,dz,rr2,rr2j,ddr,dr3,f1,f2) & !$omp private(fxi,fyi,fzi,phii,dsx,dsy,dsz) & !$omp private(fextx,fexty,fextz,phiext) & @@ -369,10 +369,9 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin !$omp reduction(min:dtsinksink) & !$omp reduction(+:phitot,merge_n) do k=1,nptmass - if (wsub) then - start_id = group_info(igcum,k) + 1 - end_id = group_info(igcum,k) + if (subsys) then i = group_info(igarg,k) + gidi = group_info(igid,k) else i = k endif @@ -398,9 +397,10 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin dsy = 0. dsz = 0. do l=1,nptmass - if (present(group_info)) then + if (subsys) then j = group_info(igarg,l) - if (j>=start_id .or. j<=end_id) cycle + gidj = group_info(igid,l) + if (gidi==gidj) cycle else j = l endif @@ -660,7 +660,7 @@ end subroutine get_gradf_sink_gas !---------------------------------------------------------------- subroutine get_gradf_sink_sink(nptmass,dt,xyzmh_ptmass,fxyz_ptmass,fsink_old,group_info) use kernel, only:kernel_softening,kernel_grad_soft,radkern - use part, only:igarg,igcum + use part, only:igarg,igid integer, intent(in) :: nptmass real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) real, intent(inout) :: fxyz_ptmass(4,nptmass) @@ -671,7 +671,14 @@ subroutine get_gradf_sink_sink(nptmass,dt,xyzmh_ptmass,fxyz_ptmass,fsink_old,gro real :: ddr,dx,dy,dz,dfx,dfy,dfz,drdotdf,rr2,dr3,g1,g2 real :: hsoft1,hsoft21,q2i,qi,psoft,fsoft,gsoft real :: gpref - integer :: i,j,k,l,start_id,end_id + integer :: i,j,k,l,gidi,gidj + logical :: subsys + + if (present(group_info)) then + subsys = .true. + else + subsys=.false. + endif if (nptmass <= 1) return if (h_soft_sinksink > 0.) then @@ -686,17 +693,16 @@ subroutine get_gradf_sink_sink(nptmass,dt,xyzmh_ptmass,fxyz_ptmass,fsink_old,gro ! !$omp parallel do default(none) & !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,fsink_old,group_info) & - !$omp shared(h_soft_sinksink,hsoft21,dt) & + !$omp shared(h_soft_sinksink,hsoft21,dt,subsys) & !$omp private(i,j,xi,yi,zi,pmassi,pmassj) & - !$omp private(start_id,end_id) & + !$omp private(gidi,gidj) & !$omp private(dx,dy,dz,dfx,dfy,dfz,drdotdf,rr2,ddr,dr3,g1,g2) & !$omp private(fxi,fyi,fzi,gxi,gyi,gzi,gpref) & !$omp private(q2i,qi,psoft,fsoft,gsoft) do k=1,nptmass - if (present(group_info)) then - start_id = group_info(igcum,k) + 1 - end_id = group_info(igcum,k) + if (subsys) then i = group_info(igarg,k) + gidi = group_info(igid,k) else i = k endif @@ -712,9 +718,10 @@ subroutine get_gradf_sink_sink(nptmass,dt,xyzmh_ptmass,fxyz_ptmass,fsink_old,gro gyi = 0. gzi = 0. do l=1,nptmass - if (present(group_info)) then + if (subsys) then j = group_info(igarg,l) - if (j>=start_id .or. j<=end_id) cycle + gidj = group_info(igid,l) + if (gidi==gidj) cycle else j = l endif diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index 049b8130f..beba710bd 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -12,7 +12,7 @@ module sdar_group public :: group_identify public :: evolve_groups ! parameters for group identification - real, parameter :: eta_pert = 0.02 + real, parameter :: eta_pert = 0.0002 real, parameter :: time_error = 1e-10 real, parameter :: max_step = 100000 real, parameter, public :: r_neigh = 0.001 @@ -50,25 +50,26 @@ end subroutine group_identify subroutine form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) - use part, only : igarg,igcum + use part, only : igarg,igcum,igid integer, intent(in) :: nptmass integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) - integer, intent(inout) :: group_info(2,nptmass) + integer, intent(inout) :: group_info(3,nptmass) integer, intent(inout) :: n_group,n_ingroup,n_sing integer :: i,ncg logical :: visited(nptmass) visited = .false. - group_info(igcum,1) = 1 + group_info(igcum,1) = 0 do i=1,nptmass if(.not.visited(i)) then n_ingroup = n_ingroup + 1 call dfs(i,visited,group_info,nmatrix,nptmass,n_ingroup,ncg) if (ncg>1)then n_group = n_group + 1 - group_info(igcum,n_group+1) = ncg + group_info(igcum,n_group) + group_info(igcum,n_group+1) = (ncg) + group_info(igcum,n_group) else n_ingroup = n_ingroup - 1 group_info(igarg,nptmass-n_sing) = i + group_info(igid,nptmass-n_sing) = i n_sing = n_sing + 1 endif endif @@ -76,11 +77,11 @@ subroutine form_group(group_info,nmatrix,nptmass,n_group,n_ingroup,n_sing) end subroutine form_group subroutine dfs(iroot,visited,group_info,nmatrix,nptmass,n_ingroup,ncg) - use part, only : igarg + use part, only : igarg,igid integer, intent(in) :: nptmass,iroot integer, intent(out) :: ncg integer(kind=1), intent(in) :: nmatrix(nptmass,nptmass) - integer, intent(inout) :: group_info(2,nptmass) + integer, intent(inout) :: group_info(3,nptmass) integer, intent(inout) :: n_ingroup logical, intent(inout) :: visited(nptmass) integer :: stack(nptmass) @@ -89,6 +90,7 @@ subroutine dfs(iroot,visited,group_info,nmatrix,nptmass,n_ingroup,ncg) ncg = 1 inode = iroot group_info(igarg,n_ingroup) = inode + group_info(igid,n_ingroup) = iroot stack_top = stack_top + 1 stack(stack_top) = inode visited(inode) = .true. @@ -103,6 +105,7 @@ subroutine dfs(iroot,visited,group_info,nmatrix,nptmass,n_ingroup,ncg) stack(stack_top) = j visited(j) = .true. group_info(igarg,n_ingroup) = j + group_info(igid,n_ingroup) = iroot endif enddo enddo @@ -181,31 +184,42 @@ end subroutine matrix_construction ! !--------------------------------------------- -subroutine evolve_groups(n_group,tnext,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) +subroutine evolve_groups(n_group,nptmass,tnext,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) use part, only: igarg,igcum + use io, only: id,master + use mpiutils,only:bcast_mpi real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),gtgrad(:,:) integer, intent(in) :: group_info(:,:) - integer, intent(inout) :: n_group + integer, intent(in) :: n_group,nptmass real, intent(in) :: tnext integer :: i,start_id,end_id,gsize - !$omp parallel do default(none)& - !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass)& - !$omp shared(tnext,group_info,gtgrad)& - !$omp private(i,start_id,end_id,gsize) - do i=1,n_group - start_id = group_info(igcum,i) + 1 - end_id = group_info(igcum,i+1) - gsize = end_id - start_id - call integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) - enddo - !$omp end parallel do + if (n_group>0) then + if(id==master) then + !$omp parallel do default(none)& + !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass)& + !$omp shared(tnext,group_info,gtgrad)& + !$omp private(i,start_id,end_id,gsize) + do i=1,n_group + start_id = group_info(igcum,i) + 1 + end_id = group_info(igcum,i+1) + gsize = end_id - start_id + call integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad) + enddo + !$omp end parallel do + endif + endif + + call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) + call bcast_mpi(vxyz_ptmass(:,1:nptmass)) end subroutine evolve_groups -subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) +subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad) + use part, only: igarg real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:), & fxyz_ptmass(:,:),gtgrad(:,:) + integer, intent(in) :: group_info(:,:) integer, intent(in) :: start_id,end_id,gsize real, intent(in) :: tnext real, allocatable :: bdata(:) @@ -216,16 +230,16 @@ subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmas real :: dt,ds_init,dt_end,step_modif,t_old,W_old real :: W,tcoord logical :: t_end_flag,backup_flag,ismultiple - integer :: i + integer :: i,prim,sec tcoord = tnext ismultiple = gsize > 2 - call initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,W,start_id,end_id,ismultiple,ds_init) + call initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,W,start_id,end_id,ismultiple,ds_init) - allocate(bdata(gsize*9)) + allocate(bdata(gsize*6)) step_count_int = 0 step_count_tsyn = 0 @@ -238,20 +252,22 @@ subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmas do while (.true.) if (backup_flag) then - call backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,bdata) + call backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,bdata) else - call restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,tcoord,t_old,W,W_old,bdata) + call restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,group_info,tcoord,t_old,W,W_old,bdata) endif t_old = tcoord W_old = W if (gsize>1) then do i=1,ck_size - call drift_TTL (tcoord,W,ds(switch)*ck(i),xyzmh_ptmass,vxyz_ptmass,start_id,end_id) + call drift_TTL (tcoord,W,ds(switch)*ck(i),xyzmh_ptmass,vxyz_ptmass,group_info,start_id,end_id) time_table(i) = tcoord - call kick_TTL (ds(switch)*dk(i),W,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,start_id,end_id) + call kick_TTL (ds(switch)*dk(i),W,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad,start_id,end_id) enddo else - call oneStep_bin(tcoord,W,ds(switch),xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,time_table,start_id,end_id) + prim = group_info(igarg,start_id) + sec = group_info(igarg,end_id) + call oneStep_bin(tcoord,W,ds(switch),xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,time_table,prim,sec) endif dt = tcoord - t_old @@ -357,46 +373,46 @@ end subroutine new_ds_sync_sup -subroutine backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,bdata) - real, intent(in) ::xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:) - real, intent(out)::bdata(:) +subroutine backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,bdata) + use part, only: igarg + real, intent(in) ::xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:) + integer,intent(in) :: group_info(:,:) + real, intent(out) ::bdata(:) integer,intent(in) :: start_id,end_id - integer :: i,j + integer :: i,j,k j=0 - do i=start_id,end_id - bdata(j*9+1) = xyzmh_ptmass(1,i) - bdata(j*9+2) = xyzmh_ptmass(2,i) - bdata(j*9+3) = xyzmh_ptmass(3,i) - bdata(j*9+4) = vxyz_ptmass(1,i) - bdata(j*9+5) = vxyz_ptmass(2,i) - bdata(j*9+6) = vxyz_ptmass(3,i) - bdata(j*9+7) = fxyz_ptmass(1,i) - bdata(j*9+8) = fxyz_ptmass(2,i) - bdata(j*9+9) = fxyz_ptmass(3,i) + do k=start_id,end_id + i = group_info(igarg,k) + bdata(j*6+1) = xyzmh_ptmass(1,i) + bdata(j*6+2) = xyzmh_ptmass(2,i) + bdata(j*6+3) = xyzmh_ptmass(3,i) + bdata(j*6+4) = vxyz_ptmass(1,i) + bdata(j*6+5) = vxyz_ptmass(2,i) + bdata(j*6+6) = vxyz_ptmass(3,i) j = j + 1 enddo end subroutine backup_data -subroutine restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,tcoord,t_old,W,W_old,bdata) +subroutine restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,group_info,tcoord,t_old,W,W_old,bdata) + use part, only: igarg real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:) + integer,intent(in) :: group_info(:,:) real, intent(out) :: tcoord,W real, intent(in) :: t_old,W_old real, intent(in) :: bdata(:) integer, intent(in) :: start_id,end_id - integer :: i,j + integer :: k,i,j j = 0 - do i=start_id,end_id - xyzmh_ptmass(1,i) = bdata(j*9+1) - xyzmh_ptmass(2,i) = bdata(j*9+2) - xyzmh_ptmass(3,i) = bdata(j*9+3) - vxyz_ptmass(1,i) = bdata(j*9+4) - vxyz_ptmass(2,i) = bdata(j*9+5) - vxyz_ptmass(3,i) = bdata(j*9+6) - fxyz_ptmass(1,i) = bdata(j*9+7) - fxyz_ptmass(2,i) = bdata(j*9+8) - fxyz_ptmass(3,i) = bdata(j*9+9) + do k=start_id,end_id + i = group_info(igarg,k) + xyzmh_ptmass(1,i) = bdata(j*6+1) + xyzmh_ptmass(2,i) = bdata(j*6+2) + xyzmh_ptmass(3,i) = bdata(j*6+3) + vxyz_ptmass(1,i) = bdata(j*6+4) + vxyz_ptmass(2,i) = bdata(j*6+5) + vxyz_ptmass(3,i) = bdata(j*6+6) j = j + 1 enddo tcoord = t_old @@ -405,19 +421,22 @@ subroutine restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,tc end subroutine restore_state -subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,s_id,e_id) +subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,group_info,s_id,e_id) + use part, only: igarg real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + integer,intent(in) :: group_info(:,:) real, intent(inout) :: tcoord real, intent(in) :: h,W integer,intent(in) :: s_id,e_id - integer :: i + integer :: k,i real :: dtd dtd = h/W tcoord = tcoord + dtd - do i=s_id,e_id + do k=s_id,e_id + i = group_info(igarg,k) xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + dtd*vxyz_ptmass(1,i) xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + dtd*vxyz_ptmass(2,i) xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + dtd*vxyz_ptmass(3,i) @@ -425,26 +444,30 @@ subroutine drift_TTL(tcoord,W,h,xyzmh_ptmass,vxyz_ptmass,s_id,e_id) end subroutine drift_TTL -subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,s_id,e_id) +subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad,s_id,e_id) + use part, only: igarg real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),gtgrad(:,:) + integer,intent(in) :: group_info(:,:) real, intent(in) :: h real, intent(inout) :: W integer,intent(in) :: s_id,e_id real :: om,dw,dtk - integer :: i + integer :: i,k - call get_force_TTL(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,s_id,e_id) + call get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id) dtk = h/om - do i=s_id,e_id + do k=s_id,e_id + i=group_info(igarg,k) vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + (0.5*dtk)*fxyz_ptmass(1,i) vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + (0.5*dtk)*fxyz_ptmass(2,i) vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + (0.5*dtk)*fxyz_ptmass(3,i) enddo dw = 0. - do i=s_id,e_id + do k=s_id,e_id + i=group_info(igarg,k) dw = dw + vxyz_ptmass(1,i)*gtgrad(1,i) + & vxyz_ptmass(2,i)*gtgrad(2,i) + & vxyz_ptmass(3,i)*gtgrad(3,i) @@ -452,7 +475,8 @@ subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,s_id,e_id) W = W + dw*dtk - do i=s_id,e_id + do k=s_id,e_id + i=group_info(igarg,k) vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + (0.5*dtk)*fxyz_ptmass(1,i) vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + (0.5*dtk)*fxyz_ptmass(2,i) vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + (0.5*dtk)*fxyz_ptmass(3,i) @@ -461,77 +485,80 @@ subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,s_id,e_id) end subroutine kick_TTL -subroutine oneStep_bin(tcoord,W,ds,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,time_table,s_id,e_id) +subroutine oneStep_bin(tcoord,W,ds,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,time_table,i,j) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),gtgrad(:,:),time_table(:) real, intent(in) :: ds real, intent(inout) :: tcoord,W - integer, intent(in) :: s_id,e_id - integer :: i + integer, intent(in) :: i,j + integer :: k real :: dtd,dtk,dvel1(3),dvel2(3),dw,om - do i = 1,ck_size - dtd = ds*ck(i)/W + do k = 1,ck_size + dtd = ds*ck(k)/W tcoord = tcoord + dtd - time_table(i) = tcoord - - xyzmh_ptmass(1,s_id) = xyzmh_ptmass(1,s_id) + dtd*vxyz_ptmass(1,s_id) - xyzmh_ptmass(2,s_id) = xyzmh_ptmass(2,s_id) + dtd*vxyz_ptmass(2,s_id) - xyzmh_ptmass(3,s_id) = xyzmh_ptmass(3,s_id) + dtd*vxyz_ptmass(3,s_id) - xyzmh_ptmass(1,e_id) = xyzmh_ptmass(1,e_id) + dtd*vxyz_ptmass(1,e_id) - xyzmh_ptmass(2,e_id) = xyzmh_ptmass(2,e_id) + dtd*vxyz_ptmass(2,e_id) - xyzmh_ptmass(3,e_id) = xyzmh_ptmass(3,e_id) + dtd*vxyz_ptmass(3,e_id) - - call get_force_TTL(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,s_id,e_id) - - dtk = ds*dk(i)/om - - dvel1(1) = 0.5*dtk*fxyz_ptmass(1,s_id) - dvel1(2) = 0.5*dtk*fxyz_ptmass(2,s_id) - dvel1(3) = 0.5*dtk*fxyz_ptmass(3,s_id) - dvel2(1) = 0.5*dtk*fxyz_ptmass(1,e_id) - dvel2(2) = 0.5*dtk*fxyz_ptmass(2,e_id) - dvel2(3) = 0.5*dtk*fxyz_ptmass(3,e_id) - - vxyz_ptmass(1,s_id) = vxyz_ptmass(1,s_id) + dvel1(1) - vxyz_ptmass(2,s_id) = vxyz_ptmass(2,s_id) + dvel1(2) - vxyz_ptmass(3,s_id) = vxyz_ptmass(3,s_id) + dvel1(3) - vxyz_ptmass(1,e_id) = vxyz_ptmass(1,e_id) + dvel2(1) - vxyz_ptmass(2,e_id) = vxyz_ptmass(2,e_id) + dvel2(2) - vxyz_ptmass(3,e_id) = vxyz_ptmass(3,e_id) + dvel2(3) - - dw = gtgrad(1,s_id)*vxyz_ptmass(1,s_id)+& - gtgrad(2,s_id)*vxyz_ptmass(2,s_id)+& - gtgrad(3,s_id)*vxyz_ptmass(3,s_id)+& - gtgrad(1,e_id)*vxyz_ptmass(1,e_id)+& - gtgrad(2,e_id)*vxyz_ptmass(2,e_id)+& - gtgrad(3,e_id)*vxyz_ptmass(3,e_id) + time_table(k) = tcoord + + xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + dtd*vxyz_ptmass(1,i) + xyzmh_ptmass(2,i) = xyzmh_ptmass(2,i) + dtd*vxyz_ptmass(2,i) + xyzmh_ptmass(3,i) = xyzmh_ptmass(3,i) + dtd*vxyz_ptmass(3,i) + xyzmh_ptmass(1,j) = xyzmh_ptmass(1,j) + dtd*vxyz_ptmass(1,j) + xyzmh_ptmass(2,j) = xyzmh_ptmass(2,j) + dtd*vxyz_ptmass(2,j) + xyzmh_ptmass(3,j) = xyzmh_ptmass(3,j) + dtd*vxyz_ptmass(3,j) + + call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j) + + dtk = ds*dk(k)/om + + dvel1(1) = 0.5*dtk*fxyz_ptmass(1,i) + dvel1(2) = 0.5*dtk*fxyz_ptmass(2,i) + dvel1(3) = 0.5*dtk*fxyz_ptmass(3,i) + dvel2(1) = 0.5*dtk*fxyz_ptmass(1,j) + dvel2(2) = 0.5*dtk*fxyz_ptmass(2,j) + dvel2(3) = 0.5*dtk*fxyz_ptmass(3,j) + + vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + dvel1(1) + vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + dvel1(2) + vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + dvel1(3) + vxyz_ptmass(1,j) = vxyz_ptmass(1,j) + dvel2(1) + vxyz_ptmass(2,j) = vxyz_ptmass(2,j) + dvel2(2) + vxyz_ptmass(3,j) = vxyz_ptmass(3,j) + dvel2(3) + + dw = gtgrad(1,i)*vxyz_ptmass(1,i)+& + gtgrad(2,i)*vxyz_ptmass(2,i)+& + gtgrad(3,i)*vxyz_ptmass(3,i)+& + gtgrad(1,j)*vxyz_ptmass(1,j)+& + gtgrad(2,j)*vxyz_ptmass(2,j)+& + gtgrad(3,j)*vxyz_ptmass(3,j) W = W + dw*dtk - vxyz_ptmass(1,s_id) = vxyz_ptmass(1,s_id) + dvel1(1) - vxyz_ptmass(2,s_id) = vxyz_ptmass(2,s_id) + dvel1(2) - vxyz_ptmass(3,s_id) = vxyz_ptmass(3,s_id) + dvel1(3) - vxyz_ptmass(1,e_id) = vxyz_ptmass(1,e_id) + dvel2(1) - vxyz_ptmass(2,e_id) = vxyz_ptmass(2,e_id) + dvel2(2) - vxyz_ptmass(3,e_id) = vxyz_ptmass(3,e_id) + dvel2(3) + vxyz_ptmass(1,i) = vxyz_ptmass(1,i) + dvel1(1) + vxyz_ptmass(2,i) = vxyz_ptmass(2,i) + dvel1(2) + vxyz_ptmass(3,i) = vxyz_ptmass(3,i) + dvel1(3) + vxyz_ptmass(1,j) = vxyz_ptmass(1,j) + dvel2(1) + vxyz_ptmass(2,j) = vxyz_ptmass(2,j) + dvel2(2) + vxyz_ptmass(3,j) = vxyz_ptmass(3,j) + dvel2(3) enddo end subroutine oneStep_bin -subroutine get_force_TTL(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,s_id,e_id) +subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id) + use part, only: igarg real, intent(in) :: xyzmh_ptmass(:,:) real, intent(inout) :: fxyz_ptmass(:,:),gtgrad(:,:) + integer,intent(in) :: group_info(:,:) real, intent(out) :: om integer, intent(in) :: s_id,e_id real :: mi,mj,xi,yi,zi,dx,dy,dz,r2,r real :: gravf,gtki - integer :: i,j + integer :: i,j,k,l om = 0. - do i=s_id,e_id + do k=s_id,e_id + i = group_info(igarg,k) fxyz_ptmass(1,i) = 0. fxyz_ptmass(2,i) = 0. fxyz_ptmass(3,i) = 0. @@ -543,15 +570,16 @@ subroutine get_force_TTL(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,s_id,e_id) yi = xyzmh_ptmass(2,i) zi = xyzmh_ptmass(3,i) mi = xyzmh_ptmass(4,i) - do j=s_id,e_id - if (i==j) cycle + do l=s_id,e_id + if (k==l) cycle + j = group_info(igarg,l) dx = xi - xyzmh_ptmass(1,j) dy = yi - xyzmh_ptmass(2,j) dz = zi - xyzmh_ptmass(3,j) - r2 = dx**2+dy**2+dz**3 - r = sqrt(r) + r2 = dx**2+dy**2+dz**2 + r = sqrt(r2) mj = xyzmh_ptmass(4,j) - gravf = xyzmh_ptmass(4,j)*(1./r2*r) + gravf = mj*(1./r2*r) gtki = gtki + mj*(1./r) fxyz_ptmass(1,i) = fxyz_ptmass(1,i) + dx*gravf fxyz_ptmass(2,i) = fxyz_ptmass(2,i) + dy*gravf @@ -567,10 +595,48 @@ subroutine get_force_TTL(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,s_id,e_id) end subroutine get_force_TTL -subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,om,s_id,e_id,ismultiple,ds_init) +subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j) + real, intent(in) :: xyzmh_ptmass(:,:) + real, intent(inout) :: fxyz_ptmass(:,:),gtgrad(:,:) + integer, intent(in) :: i,j + real, intent(out) :: om + real :: dx,dy,dz,r2,r,mi,mj + real :: gravf,gtk + + mi = xyzmh_ptmass(4,i) + mj = xyzmh_ptmass(4,j) + dx = xyzmh_ptmass(1,i)-xyzmh_ptmass(1,j) + dy = xyzmh_ptmass(2,i)-xyzmh_ptmass(2,j) + dz = xyzmh_ptmass(3,i)-xyzmh_ptmass(3,j) + r2 = dx**2+dy**2+dz**2 + r = sqrt(r2) + gravf = mj*(1./r2*r) + gtk = mj*(1./r) + + fxyz_ptmass(1,i) = dx*gravf + fxyz_ptmass(2,i) = dy*gravf + fxyz_ptmass(3,i) = dz*gravf + fxyz_ptmass(1,j) = -dx*gravf + fxyz_ptmass(2,j) = -dy*gravf + fxyz_ptmass(3,j) = -dz*gravf + + gtgrad(1,i) = dx*gravf*mi + gtgrad(2,i) = dy*gravf*mi + gtgrad(3,i) = dz*gravf*mi + gtgrad(1,j) = -dx*gravf*mi + gtgrad(2,j) = -dy*gravf*mi + gtgrad(3,j) = -dz*gravf*mi + + om = gtk*mi + +end subroutine get_force_TTL_bin + +subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,om,s_id,e_id,ismultiple,ds_init) use utils_kepler, only :extract_a_dot,extract_a,Espec + use part, only:igarg real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) real, intent(inout) :: fxyz_ptmass(:,:) + integer,intent(in) :: group_info(:,:) real, intent(out) :: om,ds_init logical, intent(in) :: ismultiple integer, intent(in) :: s_id,e_id @@ -578,18 +644,14 @@ subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,om,s_id,e_id,ismulti real :: vxi,vyi,vzi,v2,vi,dvx,dvy,dvz,v,rdotv,axi,ayi,azi,acc,gravfi real :: gravf,gtki real :: Edot,E,semi,semidot - integer :: i,j + integer :: k,l,i,j Edot = 0. E = 0. om = 0. - do i=s_id,e_id - fxyz_ptmass(1,i) = 0. - fxyz_ptmass(2,i) = 0. - fxyz_ptmass(3,i) = 0. - enddo - do i=s_id,e_id + do k=s_id,e_id + i = group_info(igarg,k) gtki = 0. gravfi = 0. xi = xyzmh_ptmass(1,i) @@ -599,16 +661,20 @@ subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,om,s_id,e_id,ismulti vxi = vxyz_ptmass(1,i) vyi = vxyz_ptmass(2,i) vzi = vxyz_ptmass(3,i) - do j=s_id,e_id - if (i==j) cycle + fxyz_ptmass(1,i) = 0. + fxyz_ptmass(2,i) = 0. + fxyz_ptmass(3,i) = 0. + do l=s_id,e_id + if (k==l) cycle + j = group_info(igarg,l) dx = xi - xyzmh_ptmass(1,j) dy = yi - xyzmh_ptmass(2,j) dz = zi - xyzmh_ptmass(3,j) dvx = vxi - vxyz_ptmass(1,j) dvy = vyi - vxyz_ptmass(2,j) dvz = vzi - vxyz_ptmass(3,j) - r2 = dx**2+dy**2+dz**3 - r = sqrt(r) + r2 = dx**2+dy**2+dz**2 + r = sqrt(r2) mj = xyzmh_ptmass(4,j) gravf = xyzmh_ptmass(4,j)*(1./r2*r) gtki = gtki + mj*(1./r) @@ -632,7 +698,7 @@ subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,om,s_id,e_id,ismulti if (ismultiple) then vi = sqrt(vxi**2 + vyi**2 + vzi**2) Edot = Edot + mi*(vi*acc - gravfi) - E = E + 0.5*mi*vi**2 - om + E = E + 0.5*mi*vi**2 - gtki else mu = mi*mj call extract_a_dot(r2,r,mu,v2,v,acc,semidot) @@ -643,9 +709,9 @@ subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,om,s_id,e_id,ismulti om = om*0.5 if (ismultiple) then - ds_init = eta_pert * (Edot/E) + ds_init = eta_pert * (E/Edot) else - ds_init = eta_pert * (semidot/semi) + ds_init = eta_pert * (semi/semidot) endif end subroutine initial_int diff --git a/src/main/step_extern.F90 b/src/main/step_extern.F90 index 310773a05..ae6124eba 100644 --- a/src/main/step_extern.F90 +++ b/src/main/step_extern.F90 @@ -550,7 +550,7 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass) real, intent(inout) :: fsink_old(4,nptmass),dsdt_ptmass(3,nptmass),gtgrad(3,nptmass) - integer, intent(inout) :: group_info(2,nptmass) + integer, intent(inout) :: group_info(3,nptmass) integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) integer, intent(inout) :: n_ingroup,n_group,n_sing real :: dt,t_end_step,dtextforce_min @@ -614,6 +614,8 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex endif enddo substeps + print*,fxyz_ptmass(2,1:nptmass) + if (nsubsteps > 1) then if (iverbose>=1 .and. id==master) then write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & diff --git a/src/main/utils_kepler.f90 b/src/main/utils_kepler.f90 index 661f3edf1..e7eb8d5a4 100644 --- a/src/main/utils_kepler.f90 +++ b/src/main/utils_kepler.f90 @@ -20,10 +20,10 @@ end subroutine extract_a subroutine extract_a_dot(r2,r,mu,v2,v,acc,adot) real, intent(in) :: r2,r,mu,v2,v,acc - real, intent(inout) :: adot + real, intent(out) :: adot real :: mu2 mu2 = mu**2 - adot = 2.*(mu2*v+r2*v*acc)/(2.*mu-r*v2)**2 + adot = 2.*(mu2*v+r2*v*acc)/((2.*mu-r*v2)**2) end subroutine extract_a_dot subroutine extract_e(x,y,z,vx,vy,vz,mu,r,eij) From 0ab8f31b7813696e607c99823bb62457d0348005 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 15 Apr 2024 12:10:32 +1000 Subject: [PATCH 16/45] fix main routine subsystem --- src/main/step_extern.F90 | 27 +++++++++++++++++---------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/src/main/step_extern.F90 b/src/main/step_extern.F90 index ae6124eba..178a0ec98 100644 --- a/src/main/step_extern.F90 +++ b/src/main/step_extern.F90 @@ -544,6 +544,8 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex use io, only:iverbose,id,master,iprint,warning,fatal use io_summary, only:summary_variable,iosumextr,iosumextt use sdar_group, only:group_identify,evolve_groups + use options, only:iexternalforce + use externalforces, only:is_velocity_dependent real, intent(in) :: dtsph,time integer, intent(in) :: npart,nptmass real, intent(inout) :: dtextforce @@ -553,10 +555,10 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex integer, intent(inout) :: group_info(3,nptmass) integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) integer, intent(inout) :: n_ingroup,n_group,n_sing - real :: dt,t_end_step,dtextforce_min - real :: pmassi,timei - logical :: done,last_step - integer :: nsubsteps + logical :: extf_vdep_flag,done,last_step + integer :: force_count,nsubsteps + real :: timei,time_par,dt,t_end_step + real :: dtextforce_min ! ! determine whether or not to use substepping @@ -570,6 +572,8 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex endif timei = time + time_par = time + extf_vdep_flag = is_velocity_dependent(iexternalforce) pmassi = massoftype(igas) t_end_step = timei + dtsph nsubsteps = 0 @@ -579,6 +583,7 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex substeps: do while (timei <= t_end_step .and. .not.done) timei = timei + dt if (abs(dt) < tiny(0.)) call fatal('step_extern','dt <= 0 in sink-gas substepping',var='dt',val=dt) + force_count = 0 nsubsteps = nsubsteps + 1 ! ! Group all the ptmass in the system in multiple small group for regularization @@ -589,15 +594,15 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup,group_info) call evolve_groups(n_group,timei,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) - call get_force(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fext, & - xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,group_info) ! Direct calculation of the force and force gradient + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag) fsink_old = fxyz_ptmass - call get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,fsink_old,group_info) + call get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,fsink_old,force_count,group_info) call kick(dk(2),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) call evolve_groups(n_group,timei,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup,group_info) - call get_force(nptmass,npart,nsubsteps,pmassi,timei,dtextforce,xyzh,fext, & - xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,group_info) + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag) call kick(dk(3),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) if (iverbose >= 2 ) write(iprint,*) "nsubsteps : ",nsubsteps,"time,dt : ",timei,dt @@ -871,12 +876,13 @@ end subroutine kick !---------------------------------------------------------------- -subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,fsink_old,group_info) +subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,fsink_old,force_count,group_info) use dim, only:maxptmass use ptmass, only:get_gradf_sink_gas,get_gradf_sink_sink,use_regnbody use mpiutils, only:reduce_in_place_mpi use io, only:id,master integer, intent(in) :: nptmass,npart + integer, intent(inout) :: force_count real, intent(inout) :: xyzh(:,:),fext(3,npart) real, intent(inout) :: xyzmh_ptmass(:,:),fxyz_ptmass(4,nptmass) real, intent(in) :: fsink_old(4,nptmass) @@ -886,6 +892,7 @@ subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptm real :: fextx,fexty,fextz integer :: i + force_count = force_count + 1 if (nptmass>0) then if(id==master) then From a9a80d6618e736fcd9bb95cc146924a5a76b8c87 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 16 Apr 2024 15:38:11 +1000 Subject: [PATCH 17/45] update main integration sub for subsys with the new design --- src/main/initial.F90 | 16 ++++++++++++---- src/main/ptmass.F90 | 3 ++- src/main/sdar_group.f90 | 2 +- src/main/step_extern.F90 | 30 ++++++++++++++++-------------- src/main/step_leapfrog.F90 | 11 +++++++++-- 5 files changed, 40 insertions(+), 22 deletions(-) diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 314b72644..126010b75 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -130,7 +130,8 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,& epot_sinksink,get_ntypes,isdead_or_accreted,dustfrac,ddustevol,& nden_nimhd,dustevol,rhoh,gradh, & - Bevol,Bxyz,dustprop,filfac,ddustprop,ndustsmall,iboundary,eos_vars,dvdx + Bevol,Bxyz,dustprop,filfac,ddustprop,ndustsmall,iboundary,eos_vars,dvdx, & + n_group,n_ingroup,n_sing,nmatrix,group_info use part, only:pxyzu,dens,metrics,rad,radprop,drad,ithick use densityforce, only:densityiterate use linklist, only:set_linklist @@ -150,7 +151,8 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use nicil_sup, only:use_consistent_gmw use ptmass, only:init_ptmass,get_accel_sink_gas,get_accel_sink_sink, & h_acc,r_crit,r_crit2,rho_crit,rho_crit_cgs,icreate_sinks, & - r_merge_uncond,r_merge_cond,r_merge_uncond2,r_merge_cond2,r_merge2 + r_merge_uncond,r_merge_cond,r_merge_uncond2,r_merge_cond2,r_merge2, & + use_regnbody use timestep, only:time,dt,dtextforce,C_force,dtmax,dtmax_user,idtmax_n use timing, only:get_timings use timestep_ind, only:ibinnow,maxbins,init_ibin,istepfrac @@ -210,6 +212,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use checkconserved, only:get_conserv,etot_in,angtot_in,totmom_in,mdust_in use fileutils, only:make_tags_unique use damping, only:idamp + use sdar_group, only:group_identify character(len=*), intent(in) :: infile character(len=*), intent(out) :: logfile,evfile,dumpfile logical, intent(in), optional :: noread @@ -495,10 +498,15 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) endif if (nptmass > 0) then if (id==master) write(iprint,"(a,i12)") ' nptmass = ',nptmass - ! compute initial sink-sink forces and get timestep - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,dtsinksink,& + if (use_regnbody) then + call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,dtsinksink,& + iexternalforce,time,merge_ij,merge_n,dsdt_ptmass,group_info=group_info) + else + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,dtsinksink,& iexternalforce,time,merge_ij,merge_n,dsdt_ptmass) + endif dtsinksink = C_force*dtsinksink if (id==master) write(iprint,*) 'dt(sink-sink) = ',dtsinksink dtextforce = min(dtextforce,dtsinksink) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 483113cd1..e2f276165 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -46,6 +46,7 @@ module ptmass public :: init_ptmass, finish_ptmass public :: pt_write_sinkev, pt_close_sinkev public :: get_accel_sink_gas, get_accel_sink_sink + public :: get_gradf_sink_gas, get_gradf_sink_sink public :: merge_sinks public :: ptmass_kick, ptmass_drift,ptmass_vdependent_correction public :: ptmass_not_obscured @@ -835,7 +836,7 @@ subroutine ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass,group_ !$omp parallel do schedule(static) default(none) & !$omp shared(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass) & - !$omp shared(n_ingroup,group_info,woutsub) & + !$omp shared(n_ingroup,group_info,woutsub,istart_ptmass) & !$omp private(i,k) do k=istart_ptmass,nptmass if (woutsub) then diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index beba710bd..f84347b54 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -188,9 +188,9 @@ subroutine evolve_groups(n_group,nptmass,tnext,group_info,xyzmh_ptmass,vxyz_ptma use part, only: igarg,igcum use io, only: id,master use mpiutils,only:bcast_mpi + integer, intent(in) :: n_group,nptmass real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),gtgrad(:,:) integer, intent(in) :: group_info(:,:) - integer, intent(in) :: n_group,nptmass real, intent(in) :: tnext integer :: i,start_id,end_id,gsize if (n_group>0) then diff --git a/src/main/step_extern.F90 b/src/main/step_extern.F90 index b7634a832..78977c559 100644 --- a/src/main/step_extern.F90 +++ b/src/main/step_extern.F90 @@ -535,7 +535,7 @@ end subroutine step_extern_pattern ! and external forces except ptmass with subsystems algorithms.. !+ !---------------------------------------------------------------- -subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass, & +subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass, & dsdt_ptmass,fsink_old,gtgrad,group_info,nmatrix,n_group,n_ingroup,n_sing) use part, only: isdead_or_accreted,igas,massoftype use io, only:iverbose,id,master,iprint,warning,fatal @@ -543,8 +543,9 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex use sdar_group, only:group_identify,evolve_groups use options, only:iexternalforce use externalforces, only:is_velocity_dependent + use ptmass, only:ck,dk real, intent(in) :: dtsph,time - integer, intent(in) :: npart,nptmass + integer, intent(in) :: npart,nptmass,ntypes real, intent(inout) :: dtextforce real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass) @@ -555,7 +556,7 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex logical :: extf_vdep_flag,done,last_step integer :: force_count,nsubsteps real :: timei,time_par,dt,t_end_step - real :: dtextforce_min + real :: dtextforce_min,pmassi ! ! determine whether or not to use substepping @@ -586,21 +587,22 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex ! Group all the ptmass in the system in multiple small group for regularization ! call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) - + !call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + ! vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag,group_info=group_info) call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup,group_info) - call evolve_groups(n_group,timei,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + call evolve_groups(n_group,nptmass,time_par,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag,group_info=group_info) fsink_old = fxyz_ptmass call get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,fsink_old,force_count,group_info) - call kick(dk(2),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - call evolve_groups(n_group,timei,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) - call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup,group_info) + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup,group_info) + call evolve_groups(n_group,nptmass,time_par,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag) - call kick(dk(3),dt,npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag,group_info=group_info) + call kick(dk(3),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) if (iverbose >= 2 ) write(iprint,*) "nsubsteps : ",nsubsteps,"time,dt : ",timei,dt dtextforce_min = min(dtextforce_min,dtextforce) @@ -616,7 +618,7 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,nptmass,xyzh,vxyzu,fex endif enddo substeps - print*,fxyz_ptmass(2,1:nptmass) + !print*,fxyz_ptmass(2,1:nptmass) if (nsubsteps > 1) then if (iverbose>=1 .and. id==master) then @@ -674,7 +676,7 @@ subroutine drift(cki,dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vx if(nptmass>0) then if(id==master) then if(present(n_ingroup)) then - call ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass,n_ingroup,group_info) + call ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass,group_info,n_ingroup) else call ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass,dsdt_ptmass) endif @@ -969,7 +971,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, real :: fextx,fexty,fextz,xi,yi,zi,pmassi,damp_fac real :: fonrmaxi,phii,dtphi2i real :: dkdt,ckdt,extrapfac - logical :: extrap,last + logical :: extrap,last,wsub if(present(fsink_old)) then fsink_old = fxyz_ptmass diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index c733e6283..3561d773f 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -127,7 +127,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use cons2primsolver, only:conservative2primitive,primitive2conservative use eos, only:equationofstate use step_extern, only:step_extern_pattern,step_extern_gr, & - step_extern_sph_gr,step_extern_sph + step_extern_sph_gr,step_extern_sph,step_extern_subsys + use ptmass, only:use_regnbody integer, intent(inout) :: npart integer, intent(in) :: nactive @@ -249,9 +250,15 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) endif else if (nptmass > 0 .or. iexternalforce > 0 .or. h2chemistry .or. cooling_in_step .or. idamp > 0) then - call step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,t,xyzh,vxyzu,& + if (use_regnbody) then + call step_extern_subsys(dtextforce,dtsph,t,npart,ntypes,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,fsink_old,gtgrad,group_info,nmatrix, & + n_group,n_ingroup,n_sing) + else + call step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,t,xyzh,vxyzu,& fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,& dptmass,fsink_old,nbinmax,ibin_wake) + endif else call step_extern_sph(dtsph,npart,xyzh,vxyzu) endif From c922e9ac320bb8fa8b2f644bbbb730b2c110c4ce Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 18 Apr 2024 08:59:25 +1000 Subject: [PATCH 18/45] continue implementation of subgroups --- src/main/ptmass.F90 | 2 +- src/main/sdar_group.f90 | 113 ++++++++++++++++++++----------------- src/main/step_extern.F90 | 30 ++++++---- src/main/step_leapfrog.F90 | 4 +- src/main/utils_sdar.f90 | 4 +- 5 files changed, 86 insertions(+), 67 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index af356533b..777e1bd98 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -317,10 +317,10 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin integer, intent(in) :: iexternalforce real, intent(in) :: ti integer, intent(out) :: merge_ij(:),merge_n - integer, optional, intent(in) :: group_info(3,nptmass) real, intent(out) :: dsdt_ptmass(3,nptmass) real, optional, intent(in) :: extrapfac real, optional, intent(in) :: fsink_old(4,nptmass) + integer, optional, intent(in) :: group_info(3,nptmass) real :: xi,yi,zi,pmassi,pmassj,fxi,fyi,fzi,phii real :: ddr,dx,dy,dz,rr2,rr2j,dr3,f1,f2 real :: hsoft1,hsoft21,q2i,qi,psoft,fsoft diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index f84347b54..8f7261af8 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -3,7 +3,7 @@ module sdar_group ! this module contains everything to identify ! and integrate regularized groups... ! -! :References: Makino et Aarseth 2002,Wang et al. 2020, Wang et al. 2021, Rantala et al. 2023 +! :References: Makkino et Aarseth 2002,Wang et al. 2020, Wang et al. 2021, Rantala et al. 2023 ! ! :Owner: Yann BERNARD ! @@ -12,11 +12,11 @@ module sdar_group public :: group_identify public :: evolve_groups ! parameters for group identification - real, parameter :: eta_pert = 0.0002 - real, parameter :: time_error = 1e-10 - real, parameter :: max_step = 100000 - real, parameter, public :: r_neigh = 0.001 - real, public :: t_crit = 0.0 + real, parameter :: eta_pert = 20 + real, parameter :: time_error = 2.5e-14 + real, parameter :: max_step = 100000000 + real, parameter, public :: r_neigh = 0.0001 + real, public :: t_crit = 1.e-9 real, public :: C_bin = 0.02 real, public :: r_search = 100.*r_neigh private @@ -29,11 +29,11 @@ module sdar_group !----------------------------------------------- subroutine group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) use io ,only:id,master,iverbose,iprint + integer, intent(in) :: nptmass real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) - integer, intent(inout) :: group_info(:,:) - integer(kind=1), intent(inout) :: nmatrix(:,:) + integer, intent(inout) :: group_info(3,nptmass) + integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) integer, intent(inout) :: n_group,n_ingroup,n_sing - integer, intent(in) :: nptmass n_group = 0 n_ingroup = 0 @@ -87,6 +87,7 @@ subroutine dfs(iroot,visited,group_info,nmatrix,nptmass,n_ingroup,ncg) integer :: stack(nptmass) integer :: j,stack_top,inode + stack_top = 0 ncg = 1 inode = iroot group_info(igarg,n_ingroup) = inode @@ -114,10 +115,10 @@ end subroutine dfs subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) use utils_kepler, only: Espec,extract_a,extract_e,extract_ea - integer(kind=1), intent(out):: nmatrix(:,:) + integer, intent(in) :: nptmass + integer(kind=1), intent(out):: nmatrix(nptmass,nptmass) real, intent(in) :: xyzmh_ptmass(:,:) real, intent(in) :: vxyz_ptmass(:,:) - integer, intent(in) :: nptmass real :: xi,yi,zi,vxi,vyi,vzi,mi real :: dx,dy,dz,dvx,dvy,dvz,r2,r,v2,mu real :: aij,eij,B,rperi @@ -169,7 +170,7 @@ subroutine matrix_construction(xyzmh_ptmass,vxyz_ptmass,nmatrix,nptmass) else call extract_e(dx,dy,dz,dvx,dvy,dvz,mu,r,eij) rperi = aij*(1-eij) - if (rperi0) then if(id==master) then !$omp parallel do default(none)& !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass)& - !$omp shared(tnext,group_info,gtgrad)& + !$omp shared(tnext,time,group_info,gtgrad)& !$omp private(i,start_id,end_id,gsize) do i=1,n_group start_id = group_info(igcum,i) + 1 end_id = group_info(igcum,i+1) - gsize = end_id - start_id - call integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad) + gsize = (end_id - start_id) + 1 + call integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad) enddo !$omp end parallel do endif @@ -215,14 +216,14 @@ subroutine evolve_groups(n_group,nptmass,tnext,group_info,xyzmh_ptmass,vxyz_ptma end subroutine evolve_groups -subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad) +subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad) use part, only: igarg real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:), & fxyz_ptmass(:,:),gtgrad(:,:) integer, intent(in) :: group_info(:,:) integer, intent(in) :: start_id,end_id,gsize - real, intent(in) :: tnext - real, allocatable :: bdata(:) + real, intent(in) :: tnext,time + real, allocatable :: bdata(:) real :: ds(2) real :: time_table(ck_size) integer :: switch @@ -233,7 +234,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmas integer :: i,prim,sec - tcoord = tnext + tcoord = time ismultiple = gsize > 2 @@ -246,9 +247,11 @@ subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmas n_step_end = 0 t_end_flag = .false. backup_flag = .true. - ds = ds_init + ds(:) = ds_init switch = 1 + !print*,ds_init, tcoord,tnext,W + do while (.true.) if (backup_flag) then @@ -258,11 +261,11 @@ subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmas endif t_old = tcoord W_old = W - if (gsize>1) then + if (gsize>2) then do i=1,ck_size - call drift_TTL (tcoord,W,ds(switch)*ck(i),xyzmh_ptmass,vxyz_ptmass,group_info,start_id,end_id) + call drift_TTL (tcoord,W,ds(switch)*cks(i),xyzmh_ptmass,vxyz_ptmass,group_info,start_id,end_id) time_table(i) = tcoord - call kick_TTL (ds(switch)*dk(i),W,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad,start_id,end_id) + call kick_TTL (ds(switch)*dks(i),W,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,gtgrad,start_id,end_id) enddo else prim = group_info(igarg,start_id) @@ -324,6 +327,8 @@ subroutine integrate_to_time(start_id,end_id,gsize,tnext,xyzmh_ptmass,vxyz_ptmas endif enddo + print*,step_count_int,tcoord,tnext,ds_init + deallocate(bdata) end subroutine integrate_to_time @@ -494,8 +499,9 @@ subroutine oneStep_bin(tcoord,W,ds,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,t real :: dtd,dtk,dvel1(3),dvel2(3),dw,om do k = 1,ck_size - dtd = ds*ck(k)/W + dtd = ds*cks(k)/W tcoord = tcoord + dtd + !if (i == 1) print*, fxyz_ptmass(1,i),i,j time_table(k) = tcoord xyzmh_ptmass(1,i) = xyzmh_ptmass(1,i) + dtd*vxyz_ptmass(1,i) @@ -507,7 +513,7 @@ subroutine oneStep_bin(tcoord,W,ds,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,t call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j) - dtk = ds*dk(k)/om + dtk = ds*dks(k)/om dvel1(1) = 0.5*dtk*fxyz_ptmass(1,i) dvel1(2) = 0.5*dtk*fxyz_ptmass(2,i) @@ -600,34 +606,37 @@ subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j) real, intent(inout) :: fxyz_ptmass(:,:),gtgrad(:,:) integer, intent(in) :: i,j real, intent(out) :: om - real :: dx,dy,dz,r2,r,mi,mj - real :: gravf,gtk + real :: dx,dy,dz,r2,r,ddr3,mi,mj + real :: gravfi,gtki,gravfj,gtkj mi = xyzmh_ptmass(4,i) mj = xyzmh_ptmass(4,j) - dx = xyzmh_ptmass(1,i)-xyzmh_ptmass(1,j) - dy = xyzmh_ptmass(2,i)-xyzmh_ptmass(2,j) - dz = xyzmh_ptmass(3,i)-xyzmh_ptmass(3,j) + dx = xyzmh_ptmass(1,i) - xyzmh_ptmass(1,j) + dy = xyzmh_ptmass(2,i) - xyzmh_ptmass(2,j) + dz = xyzmh_ptmass(3,i) - xyzmh_ptmass(3,j) r2 = dx**2+dy**2+dz**2 r = sqrt(r2) - gravf = mj*(1./r2*r) - gtk = mj*(1./r) - - fxyz_ptmass(1,i) = dx*gravf - fxyz_ptmass(2,i) = dy*gravf - fxyz_ptmass(3,i) = dz*gravf - fxyz_ptmass(1,j) = -dx*gravf - fxyz_ptmass(2,j) = -dy*gravf - fxyz_ptmass(3,j) = -dz*gravf - - gtgrad(1,i) = dx*gravf*mi - gtgrad(2,i) = dy*gravf*mi - gtgrad(3,i) = dz*gravf*mi - gtgrad(1,j) = -dx*gravf*mi - gtgrad(2,j) = -dy*gravf*mi - gtgrad(3,j) = -dz*gravf*mi - - om = gtk*mi + ddr3 = (1./(r2*r)) + gravfi = mj*ddr3 + gravfj = mi*ddr3 + gtki = mj*(1./r) + gtkj = mi*(1./r) + + fxyz_ptmass(1,i) = -dx*gravfi + fxyz_ptmass(2,i) = -dy*gravfi + fxyz_ptmass(3,i) = -dz*gravfi + fxyz_ptmass(1,j) = dx*gravfj + fxyz_ptmass(2,j) = dy*gravfj + fxyz_ptmass(3,j) = dz*gravfj + + gtgrad(1,i) = -dx*gravfi*mi + gtgrad(2,i) = -dy*gravfi*mi + gtgrad(3,i) = -dz*gravfi*mi + gtgrad(1,j) = dx*gravfj*mj + gtgrad(2,j) = dy*gravfj*mj + gtgrad(3,j) = dz*gravfj*mj + + om = gtki*mi end subroutine get_force_TTL_bin @@ -709,9 +718,9 @@ subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,om,s_id,e om = om*0.5 if (ismultiple) then - ds_init = eta_pert * (E/Edot) + ds_init = eta_pert * abs(E/Edot) else - ds_init = eta_pert * (semi/semidot) + ds_init = eta_pert * abs(semi/semidot) endif end subroutine initial_int diff --git a/src/main/step_extern.F90 b/src/main/step_extern.F90 index 91ba089ca..670085d80 100644 --- a/src/main/step_extern.F90 +++ b/src/main/step_extern.F90 @@ -538,8 +538,8 @@ end subroutine step_extern_pattern !+ !---------------------------------------------------------------- subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass, & - dsdt_ptmass,fsink_old,gtgrad,group_info,nmatrix,n_group,n_ingroup,n_sing) - use part, only: isdead_or_accreted,igas,massoftype + dsdt_ptmass,dptmass,fsink_old,nbinmax,ibin_wake,gtgrad,group_info,nmatrix,n_group,n_ingroup,n_sing) + use part, only:isdead_or_accreted,igas,massoftype,fxyz_ptmass_sinksink use io, only:iverbose,id,master,iprint,warning,fatal use io_summary, only:summary_variable,iosumextr,iosumextt use sdar_group, only:group_identify,evolve_groups @@ -551,9 +551,12 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vx real, intent(inout) :: dtextforce real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass) + real, intent(inout) :: dptmass(:,:) real, intent(inout) :: fsink_old(4,nptmass),dsdt_ptmass(3,nptmass),gtgrad(3,nptmass) integer, intent(inout) :: group_info(3,nptmass) integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) + integer(kind=1), intent(in) :: nbinmax + integer(kind=1), intent(inout) :: ibin_wake(:) integer, intent(inout) :: n_ingroup,n_group,n_sing logical :: extf_vdep_flag,done,last_step integer :: force_count,nsubsteps @@ -593,18 +596,24 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vx ! vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag,group_info=group_info) call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup,group_info) - call evolve_groups(n_group,nptmass,time_par,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + call evolve_groups(n_group,nptmass,time_par,time_par+ck(1)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag,group_info=group_info) fsink_old = fxyz_ptmass call get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,fsink_old,force_count,group_info) + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,dsdt_ptmass,n_ingroup,group_info) - call evolve_groups(n_group,nptmass,time_par,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + + call evolve_groups(n_group,nptmass,time_par,time_par+ck(2)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + + call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag,group_info=group_info) - call kick(dk(3),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + + call kick(dk(3),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass, & + dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink) if (iverbose >= 2 ) write(iprint,*) "nsubsteps : ",nsubsteps,"time,dt : ",timei,dt dtextforce_min = min(dtextforce_min,dtextforce) @@ -620,7 +629,6 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vx endif enddo substeps - !print*,fxyz_ptmass(2,1:nptmass) if (nsubsteps > 1) then if (iverbose>=1 .and. id==master) then @@ -655,7 +663,7 @@ subroutine drift(cki,dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vx real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) integer, optional, intent(in) :: n_ingroup integer, optional, intent(in) :: group_info(:,:) - integer :: i,k + integer :: i real :: ckdt ckdt = cki*dt @@ -862,7 +870,7 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, call summary_accrete_fail(nfail) call summary_accrete(nptmass) ! only write to .ev during substeps if no gas particles present - if (npart==0) call pt_write_sinkev(nptmass,timei,xyzmh_ptmass,vxyz_ptmass, & + if (npart==-1) call pt_write_sinkev(nptmass,timei,xyzmh_ptmass,vxyz_ptmass, & fxyz_ptmass,fxyz_ptmass_sinksink) endif endif @@ -1027,6 +1035,8 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,group_info=group_info) + fxyz_ptmass_sinksink=fxyz_ptmass + dsdt_ptmass_sinksink=dsdt_ptmass endif else call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 3561d773f..478c46ec6 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -252,8 +252,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (nptmass > 0 .or. iexternalforce > 0 .or. h2chemistry .or. cooling_in_step .or. idamp > 0) then if (use_regnbody) then call step_extern_subsys(dtextforce,dtsph,t,npart,ntypes,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,fsink_old,gtgrad,group_info,nmatrix, & - n_group,n_ingroup,n_sing) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dptmass,fsink_old,nbinmax,ibin_wake, & + gtgrad,group_info,nmatrix,n_group,n_ingroup,n_sing) else call step_extern_pattern(npart,ntypes,nptmass,dtsph,dtextforce,t,xyzh,vxyzu,& fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,& diff --git a/src/main/utils_sdar.f90 b/src/main/utils_sdar.f90 index 8ca52f85f..7b0ce4401 100644 --- a/src/main/utils_sdar.f90 +++ b/src/main/utils_sdar.f90 @@ -1,13 +1,13 @@ module utils_sdar implicit none integer, parameter :: ck_size = 8 - real,dimension(8),parameter :: ck=(/0.3922568052387800,0.5100434119184585,-0.4710533854097566,& + real,dimension(8),parameter :: cks=(/0.3922568052387800,0.5100434119184585,-0.4710533854097566,& 0.0687531682525181,0.0687531682525181,-0.4710533854097566,& 0.5100434119184585,0.3922568052387800/) real,dimension(8),parameter :: cck_sorted=(/0.0976997828427615,0.3922568052387800,0.4312468317474820,& 0.5000000000000000,0.5687531682525181,0.6077431947612200,& 0.9023002171572385,1.0000000000000000/) - real,dimension(8),parameter :: dk=(/0.7845136104775600,0.2355732133593570,-1.1776799841788701,& + real,dimension(8),parameter :: dks=(/0.7845136104775600,0.2355732133593570,-1.1776799841788701,& 1.3151863206839063,-1.1776799841788701,0.2355732133593570,& 0.7845136104775600,0.0000000000000000/) integer,dimension(8),parameter :: cck_sorted_id=(/6,1,3,4,5,7,2,8/) From e07a0521e05ced80523fe0f6425d13d1190679e1 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 19 Apr 2024 09:49:36 +1000 Subject: [PATCH 19/45] fix latest merge... --- src/main/sdar_group.f90 | 4 ++-- src/main/substepping.F90 | 1 - src/setup/setup_starcluster.f90 | 2 +- 3 files changed, 3 insertions(+), 4 deletions(-) diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index 8f7261af8..039c710f3 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -327,7 +327,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ endif enddo - print*,step_count_int,tcoord,tnext,ds_init + !print*,step_count_int,tcoord,tnext,ds_init deallocate(bdata) @@ -585,7 +585,7 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id r2 = dx**2+dy**2+dz**2 r = sqrt(r2) mj = xyzmh_ptmass(4,j) - gravf = mj*(1./r2*r) + gravf = mj*(1./(r2*r)) gtki = gtki + mj*(1./r) fxyz_ptmass(1,i) = fxyz_ptmass(1,i) + dx*gravf fxyz_ptmass(2,i) = fxyz_ptmass(2,i) + dy*gravf diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 9740a3337..54234da06 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -564,7 +564,6 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vx use sdar_group, only:group_identify,evolve_groups use options, only:iexternalforce use externalforces, only:is_velocity_dependent - use ptmass, only:ck,dk real, intent(in) :: dtsph,time integer, intent(in) :: npart,nptmass,ntypes real, intent(inout) :: dtextforce diff --git a/src/setup/setup_starcluster.f90 b/src/setup/setup_starcluster.f90 index fcadfe5b9..2d3f43e06 100644 --- a/src/setup/setup_starcluster.f90 +++ b/src/setup/setup_starcluster.f90 @@ -132,7 +132,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! setup initial sphere of particles to prevent initialisation problems ! psep = 1.0 - call set_sphere('cubic',id,master,0.,10.0,psep,hfact,npart,xyzh) + call set_sphere('cubic',id,master,0.,0.01,psep,hfact,npart,xyzh) vxyzu(4,:) = 5.317e-4 npartoftype(igas) = npart From 493dfa90f2cfc5cc941ec8308e5b414ec7b4cc6d Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 19 Apr 2024 14:56:22 +1000 Subject: [PATCH 20/45] split init int for sub --- src/main/sdar_group.f90 | 173 +++++++++++++++++++++++++++------------- 1 file changed, 116 insertions(+), 57 deletions(-) diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index 039c710f3..ef482c39b 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -238,7 +238,13 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ ismultiple = gsize > 2 - call initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,W,start_id,end_id,ismultiple,ds_init) + if(ismultiple) then + call initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,W,start_id,end_id,ds_init) + else + prim = group_info(igarg,start_id) + sec = group_info(igarg,end_id) + call initial_int_bin(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,W,prim,sec,ds_init) + endif allocate(bdata(gsize*6)) @@ -261,7 +267,7 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ endif t_old = tcoord W_old = W - if (gsize>2) then + if (ismultiple) then do i=1,ck_size call drift_TTL (tcoord,W,ds(switch)*cks(i),xyzmh_ptmass,vxyz_ptmass,group_info,start_id,end_id) time_table(i) = tcoord @@ -558,19 +564,19 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id real, intent(out) :: om integer, intent(in) :: s_id,e_id real :: mi,mj,xi,yi,zi,dx,dy,dz,r2,r - real :: gravf,gtki + real :: gravf,gtki,gravfi(3),gtgradi(3) integer :: i,j,k,l om = 0. do k=s_id,e_id i = group_info(igarg,k) - fxyz_ptmass(1,i) = 0. - fxyz_ptmass(2,i) = 0. - fxyz_ptmass(3,i) = 0. - gtgrad(1,i) = 0. - gtgrad(2,i) = 0. - gtgrad(3,i) = 0. + gravfi(1) = 0. + gravfi(2) = 0. + gravfi(3) = 0. + gtgradi(1) = 0. + gtgradi(2) = 0. + gtgradi(3) = 0. gtki = 0. xi = xyzmh_ptmass(1,i) yi = xyzmh_ptmass(2,i) @@ -587,13 +593,20 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id mj = xyzmh_ptmass(4,j) gravf = mj*(1./(r2*r)) gtki = gtki + mj*(1./r) - fxyz_ptmass(1,i) = fxyz_ptmass(1,i) + dx*gravf - fxyz_ptmass(2,i) = fxyz_ptmass(2,i) + dy*gravf - fxyz_ptmass(3,i) = fxyz_ptmass(3,i) + dz*gravf - gtgrad(1,i) = gtgrad(1,i) + dx*gravf*mi - gtgrad(2,i) = gtgrad(2,i) + dy*gravf*mi - gtgrad(3,i) = gtgrad(3,i) + dz*gravf*mi + gravfi(1) = gravfi(1) + dx*gravf + gravfi(2) = gravfi(2) + dy*gravf + gravfi(3) = gravfi(3) + dz*gravf + gtgradi(1) = gtgradi(1) + dx*gravf*mi + gtgradi(2) = gtgradi(2) + dy*gravf*mi + gtgradi(3) = gtgradi(3) + dz*gravf*mi enddo + fxyz_ptmass(1,i) = gravfi(1) + fxyz_ptmass(2,i) = gravfi(2) + fxyz_ptmass(3,i) = gravfi(3) + gtgrad(1,i) = gtgradi(1) + gtgrad(2,i) = gtgradi(2) + gtgrad(3,i) = gtgradi(3) + om = om + gtki*mi enddo @@ -607,7 +620,7 @@ subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j) integer, intent(in) :: i,j real, intent(out) :: om real :: dx,dy,dz,r2,r,ddr3,mi,mj - real :: gravfi,gtki,gravfj,gtkj + real :: gravfi,gtki,gravfj mi = xyzmh_ptmass(4,i) mj = xyzmh_ptmass(4,j) @@ -620,7 +633,6 @@ subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j) gravfi = mj*ddr3 gravfj = mi*ddr3 gtki = mj*(1./r) - gtkj = mi*(1./r) fxyz_ptmass(1,i) = -dx*gravfi fxyz_ptmass(2,i) = -dy*gravfi @@ -640,24 +652,24 @@ subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j) end subroutine get_force_TTL_bin -subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,om,s_id,e_id,ismultiple,ds_init) +subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,om,s_id,e_id,ds_init) use utils_kepler, only :extract_a_dot,extract_a,Espec use part, only:igarg real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) real, intent(inout) :: fxyz_ptmass(:,:) integer,intent(in) :: group_info(:,:) real, intent(out) :: om,ds_init - logical, intent(in) :: ismultiple integer, intent(in) :: s_id,e_id - real :: mi,mj,mu,xi,yi,zi,dx,dy,dz,r,r2 - real :: vxi,vyi,vzi,v2,vi,dvx,dvy,dvz,v,rdotv,axi,ayi,azi,acc,gravfi - real :: gravf,gtki - real :: Edot,E,semi,semidot + real :: mi,mj,xi,yi,zi,dx,dy,dz,r,r2 + real :: vxi,vyi,vzi,v,dvx,dvy,dvz,rdotv,axi,ayi,azi,acc,gravrdotv + real :: gravf,gravfi(3),gtki + real :: Edot,E integer :: k,l,i,j Edot = 0. E = 0. om = 0. + gravrdotv = 0. do k=s_id,e_id i = group_info(igarg,k) @@ -670,9 +682,12 @@ subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,om,s_id,e vxi = vxyz_ptmass(1,i) vyi = vxyz_ptmass(2,i) vzi = vxyz_ptmass(3,i) - fxyz_ptmass(1,i) = 0. - fxyz_ptmass(2,i) = 0. - fxyz_ptmass(3,i) = 0. + axi = fxyz_ptmass(1,i) + ayi = fxyz_ptmass(2,i) + azi = fxyz_ptmass(3,i) + gravfi(1) = 0. + gravfi(2) = 0. + gravfi(3) = 0. do l=s_id,e_id if (k==l) cycle j = group_info(igarg,l) @@ -685,44 +700,88 @@ subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,om,s_id,e r2 = dx**2+dy**2+dz**2 r = sqrt(r2) mj = xyzmh_ptmass(4,j) - gravf = xyzmh_ptmass(4,j)*(1./r2*r) + gravf = mj*(1./(r2*r)) gtki = gtki + mj*(1./r) - fxyz_ptmass(1,i) = fxyz_ptmass(1,i) + dx*gravf - fxyz_ptmass(2,i) = fxyz_ptmass(2,i) + dy*gravf - fxyz_ptmass(3,i) = fxyz_ptmass(3,i) + dz*gravf - if (ismultiple) then - rdotv = dx*dvx + dy*dvy + dz*dvz - gravfi = gravfi + gravf*rdotv - else - v2 = dvx**2 + dvy**2 + dvz**2 - v = sqrt(v2) - endif - + gravfi(1) = gravfi(1) + dx*gravf + gravfi(2) = gravfi(2) + dy*gravf + gravfi(3) = gravfi(3) + dz*gravf + rdotv = dx*dvx + dy*dvy + dz*dvz + gravrdotv = gravrdotv + gravf*rdotv enddo om = om + gtki*mi - axi = fxyz_ptmass(1,i) - ayi = fxyz_ptmass(2,i) - azi = fxyz_ptmass(3,i) + axi = axi + gravfi(1) + ayi = ayi + gravfi(2) + azi = azi + gravfi(3) acc = sqrt(axi**2 + ayi**2 + azi**2) - if (ismultiple) then - vi = sqrt(vxi**2 + vyi**2 + vzi**2) - Edot = Edot + mi*(vi*acc - gravfi) - E = E + 0.5*mi*vi**2 - gtki - else - mu = mi*mj - call extract_a_dot(r2,r,mu,v2,v,acc,semidot) - call extract_a(r,mu,v2,semi) - endif + v = sqrt(vxi**2 + vyi**2 + vzi**2) + Edot = Edot + mi*(v*acc - gravrdotv) + E = E + 0.5*mi*v**2 - gtki enddo - om = om*0.5 - - if (ismultiple) then - ds_init = eta_pert * abs(E/Edot) - else - ds_init = eta_pert * abs(semi/semidot) - endif + ds_init = eta_pert * abs(E/Edot) + om = om*0.5 end subroutine initial_int +subroutine initial_int_bin(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,om,i,j,ds_init) + use utils_kepler, only :extract_a_dot,extract_a,Espec + use part, only:igarg + real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + real, intent(inout) :: fxyz_ptmass(:,:) + integer,intent(in) :: group_info(:,:) + real, intent(out) :: om,ds_init + integer, intent(in) :: i,j + real :: mi,mj,mu,dx,dy,dz,r,r2,ddr3 + real :: v,v2,dvx,dvy,dvz + real :: dax,day,daz,acc + real :: gravfi,gravfj,gtki + real :: semi,semidot + + om = 0. + + + + mi = xyzmh_ptmass(4,i) + mj = xyzmh_ptmass(4,j) + dx = xyzmh_ptmass(1,i) - xyzmh_ptmass(1,j) + dy = xyzmh_ptmass(2,i) - xyzmh_ptmass(2,j) + dz = xyzmh_ptmass(3,i) - xyzmh_ptmass(3,j) + dvx = vxyz_ptmass(1,i) - vxyz_ptmass(1,j) + dvy = vxyz_ptmass(2,i) - vxyz_ptmass(2,j) + dvz = vxyz_ptmass(3,i) - vxyz_ptmass(3,j) + + r2 = dx**2+dy**2+dz**2 + r = sqrt(r2) + v2 = dvx**2 + dvy**2 + dvz**2 + v = sqrt(v2) + + ddr3 = (1./(r2*r)) + gravfi = mj*ddr3 + gravfj = mi*ddr3 + gtki = mj*(1./r) + + fxyz_ptmass(1,i) = fxyz_ptmass(1,i) - dx*gravfi + fxyz_ptmass(2,i) = fxyz_ptmass(2,i) - dy*gravfi + fxyz_ptmass(3,i) = fxyz_ptmass(3,i) - dz*gravfi + fxyz_ptmass(1,j) = fxyz_ptmass(1,j) + dx*gravfj + fxyz_ptmass(2,j) = fxyz_ptmass(2,j) + dy*gravfj + fxyz_ptmass(3,j) = fxyz_ptmass(3,j) + dz*gravfj + + dax = fxyz_ptmass(1,i) - fxyz_ptmass(1,j) + day = fxyz_ptmass(2,i) - fxyz_ptmass(2,j) + daz = fxyz_ptmass(3,i) - fxyz_ptmass(3,j) + + acc = sqrt(dax**2 + day**2 + daz**2) + mu = mi*mj + + call extract_a_dot(r2,r,mu,v2,v,acc,semidot) + call extract_a(r,mu,v2,semi) + + ds_init = eta_pert * abs(semi/semidot) + om = gtki*mi + + print*,abs(semidot/semi),5.e-5/(r2*acc/(mi+mj)),ds_init + +end subroutine initial_int_bin + end module sdar_group From dc41fc51ec0d25d1df4080d8a0461f583fc9a908 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 23 Apr 2024 12:22:56 +1000 Subject: [PATCH 21/45] accounting for epot from subgroups --- src/main/energies.F90 | 14 +- src/main/sdar_group.f90 | 286 ++++++++++++++++----------------------- src/main/substepping.F90 | 4 +- 3 files changed, 130 insertions(+), 174 deletions(-) diff --git a/src/main/energies.F90 b/src/main/energies.F90 index 27684ce97..9af4f5a66 100644 --- a/src/main/energies.F90 +++ b/src/main/energies.F90 @@ -70,7 +70,7 @@ subroutine compute_energies(t) isdead_or_accreted,epot_sinksink,imacc,ispinx,ispiny,& ispinz,mhd,gravity,poten,dustfrac,eos_vars,itemp,igasP,ics,& nden_nimhd,eta_nimhd,iion,ndustsmall,graindens,grainsize,& - iamdust,ndusttypes,rad,iradxi + iamdust,ndusttypes,rad,iradxi,gtgrad,group_info,n_group use part, only:pxyzu,fxyzu,fext use gravwaveutils, only:calculate_strain,calc_gravitwaves use centreofmass, only:get_centreofmass_accel @@ -80,7 +80,8 @@ subroutine compute_energies(t) use externalforces, only:externalforce,externalforce_vdependent,was_accreted,accradius1 use options, only:iexternalforce,calc_erot,alpha,ieos,use_dustfrac use mpiutils, only:reduceall_mpi - use ptmass, only:get_accel_sink_gas + use ptmass, only:get_accel_sink_gas,use_regnbody + use sdar_group, only:get_pot_subsys use viscosity, only:irealvisc,shearfunc use nicil, only:nicil_update_nimhd,nicil_get_halldrift,nicil_get_ambidrift, & use_ohm,use_hall,use_ambi,n_data_out,n_warn,eta_constant @@ -600,7 +601,14 @@ subroutine compute_energies(t) emag = reduceall_mpi('+',emag) epot = reduceall_mpi('+',epot) erad = reduceall_mpi('+',erad) - if (nptmass > 1) epot = epot + epot_sinksink + if (nptmass > 1) then + if (use_regnbody) then + call get_pot_subsys(n_group,nptmass,group_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) + endif + epot = epot + epot_sinksink + endif + + etot = ekin + etherm + emag + epot + erad diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index ef482c39b..81c015365 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -11,6 +11,7 @@ module sdar_group implicit none public :: group_identify public :: evolve_groups + public :: get_pot_subsys ! parameters for group identification real, parameter :: eta_pert = 20 real, parameter :: time_error = 2.5e-14 @@ -239,13 +240,14 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ ismultiple = gsize > 2 if(ismultiple) then - call initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,W,start_id,end_id,ds_init) + call get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,W,start_id,end_id,ds_init=ds_init) else prim = group_info(igarg,start_id) sec = group_info(igarg,end_id) - call initial_int_bin(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,W,prim,sec,ds_init) + call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,W,prim,sec,ds_init=ds_init) endif + allocate(bdata(gsize*6)) step_count_int = 0 @@ -556,15 +558,17 @@ subroutine oneStep_bin(tcoord,W,ds,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad,t end subroutine oneStep_bin -subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id) +subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id,potonly,ds_init) use part, only: igarg - real, intent(in) :: xyzmh_ptmass(:,:) - real, intent(inout) :: fxyz_ptmass(:,:),gtgrad(:,:) - integer,intent(in) :: group_info(:,:) - real, intent(out) :: om - integer, intent(in) :: s_id,e_id - real :: mi,mj,xi,yi,zi,dx,dy,dz,r2,r - real :: gravf,gtki,gravfi(3),gtgradi(3) + real, intent(in) :: xyzmh_ptmass(:,:) + real, intent(inout) :: fxyz_ptmass(:,:),gtgrad(:,:) + integer, intent(in) :: group_info(:,:) + real, intent(out) :: om + integer, intent(in) :: s_id,e_id + logical, optional, intent(in) :: potonly + real, optional, intent(out) :: ds_init + real :: mi,mj,xi,yi,zi,dx,dy,dz,r2,ddr,ddr3 + real :: gravf,gtki,gravfi(3),gtgradi(3),f2 integer :: i,j,k,l om = 0. @@ -589,38 +593,53 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id dy = yi - xyzmh_ptmass(2,j) dz = zi - xyzmh_ptmass(3,j) r2 = dx**2+dy**2+dz**2 - r = sqrt(r2) + ddr = 1./sqrt(r2) mj = xyzmh_ptmass(4,j) - gravf = mj*(1./(r2*r)) - gtki = gtki + mj*(1./r) - gravfi(1) = gravfi(1) + dx*gravf - gravfi(2) = gravfi(2) + dy*gravf - gravfi(3) = gravfi(3) + dz*gravf - gtgradi(1) = gtgradi(1) + dx*gravf*mi - gtgradi(2) = gtgradi(2) + dy*gravf*mi - gtgradi(3) = gtgradi(3) + dz*gravf*mi + gtki = gtki + mj*ddr + if (.not.present(potonly)) then + ddr3 = ddr*ddr*ddr + gravf = mj*(1./ddr3) + gravfi(1) = gravfi(1) + dx*gravf + gravfi(2) = gravfi(2) + dy*gravf + gravfi(3) = gravfi(3) + dz*gravf + gtgradi(1) = gtgradi(1) + dx*gravf*mi + gtgradi(2) = gtgradi(2) + dy*gravf*mi + gtgradi(3) = gtgradi(3) + dz*gravf*mi + endif enddo - fxyz_ptmass(1,i) = gravfi(1) - fxyz_ptmass(2,i) = gravfi(2) - fxyz_ptmass(3,i) = gravfi(3) - gtgrad(1,i) = gtgradi(1) - gtgrad(2,i) = gtgradi(2) - gtgrad(3,i) = gtgradi(3) + fxyz_ptmass(4,i) = -gtki + if (.not.present(potonly)) then + fxyz_ptmass(1,i) = gravfi(1) + fxyz_ptmass(2,i) = gravfi(2) + fxyz_ptmass(3,i) = gravfi(3) + gtgrad(1,i) = gtgradi(1) + gtgrad(2,i) = gtgradi(2) + gtgrad(3,i) = gtgradi(3) + endif + if (present(ds_init)) then + f2 = gravfi(1)**2+gravfi(2)**2+gravfi(3)**2 + if (f2 > 0.) then + ds_init = min(ds_init,0.00002*sqrt(abs(gtki)/f2)) + endif + endif om = om + gtki*mi enddo om = om*0.5 + if(present(ds_init)) ds_init = ds_init/om end subroutine get_force_TTL -subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j) +subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j,potonly,ds_init) real, intent(in) :: xyzmh_ptmass(:,:) real, intent(inout) :: fxyz_ptmass(:,:),gtgrad(:,:) integer, intent(in) :: i,j real, intent(out) :: om - real :: dx,dy,dz,r2,r,ddr3,mi,mj - real :: gravfi,gtki,gravfj + logical, optional, intent(in) :: potonly + real, optional, intent(out) :: ds_init + real :: dx,dy,dz,r2,ddr,ddr3,mi,mj,dsi,dsj + real :: gravfi,gravfj,gtki,gtkj,fxi,fyi,fzi,fxj,fyj,fzj,f2i,f2j mi = xyzmh_ptmass(4,i) mj = xyzmh_ptmass(4,j) @@ -628,160 +647,89 @@ subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j) dy = xyzmh_ptmass(2,i) - xyzmh_ptmass(2,j) dz = xyzmh_ptmass(3,i) - xyzmh_ptmass(3,j) r2 = dx**2+dy**2+dz**2 - r = sqrt(r2) - ddr3 = (1./(r2*r)) + ddr = 1./sqrt(r2) + ddr3 = ddr*ddr*ddr gravfi = mj*ddr3 gravfj = mi*ddr3 - gtki = mj*(1./r) - - fxyz_ptmass(1,i) = -dx*gravfi - fxyz_ptmass(2,i) = -dy*gravfi - fxyz_ptmass(3,i) = -dz*gravfi - fxyz_ptmass(1,j) = dx*gravfj - fxyz_ptmass(2,j) = dy*gravfj - fxyz_ptmass(3,j) = dz*gravfj - - gtgrad(1,i) = -dx*gravfi*mi - gtgrad(2,i) = -dy*gravfi*mi - gtgrad(3,i) = -dz*gravfi*mi - gtgrad(1,j) = dx*gravfj*mj - gtgrad(2,j) = dy*gravfj*mj - gtgrad(3,j) = dz*gravfj*mj + gtki = mj*ddr + gtkj = mi*ddr + + + fxyz_ptmass(4,i) = -gtki + fxyz_ptmass(4,j) = -gtkj + if(.not.present(potonly)) then + fxi = -dx*gravfi + fyi = -dy*gravfi + fzi = -dz*gravfi + fxj = dx*gravfj + fyj = dy*gravfj + fzj = dz*gravfj + fxyz_ptmass(1,i) = fxi + fxyz_ptmass(2,i) = fyi + fxyz_ptmass(3,i) = fzi + fxyz_ptmass(1,j) = fxj + fxyz_ptmass(2,j) = fyj + fxyz_ptmass(3,j) = fzj + gtgrad(1,i) = -dx*gravfi*mi + gtgrad(2,i) = -dy*gravfi*mi + gtgrad(3,i) = -dz*gravfi*mi + gtgrad(1,j) = dx*gravfj*mj + gtgrad(2,j) = dy*gravfj*mj + gtgrad(3,j) = dz*gravfj*mj + endif om = gtki*mi -end subroutine get_force_TTL_bin - -subroutine initial_int(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,om,s_id,e_id,ds_init) - use utils_kepler, only :extract_a_dot,extract_a,Espec - use part, only:igarg - real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) - real, intent(inout) :: fxyz_ptmass(:,:) - integer,intent(in) :: group_info(:,:) - real, intent(out) :: om,ds_init - integer, intent(in) :: s_id,e_id - real :: mi,mj,xi,yi,zi,dx,dy,dz,r,r2 - real :: vxi,vyi,vzi,v,dvx,dvy,dvz,rdotv,axi,ayi,azi,acc,gravrdotv - real :: gravf,gravfi(3),gtki - real :: Edot,E - integer :: k,l,i,j - - Edot = 0. - E = 0. - om = 0. - gravrdotv = 0. - - do k=s_id,e_id - i = group_info(igarg,k) - gtki = 0. - gravfi = 0. - xi = xyzmh_ptmass(1,i) - yi = xyzmh_ptmass(2,i) - zi = xyzmh_ptmass(3,i) - mi = xyzmh_ptmass(4,i) - vxi = vxyz_ptmass(1,i) - vyi = vxyz_ptmass(2,i) - vzi = vxyz_ptmass(3,i) - axi = fxyz_ptmass(1,i) - ayi = fxyz_ptmass(2,i) - azi = fxyz_ptmass(3,i) - gravfi(1) = 0. - gravfi(2) = 0. - gravfi(3) = 0. - do l=s_id,e_id - if (k==l) cycle - j = group_info(igarg,l) - dx = xi - xyzmh_ptmass(1,j) - dy = yi - xyzmh_ptmass(2,j) - dz = zi - xyzmh_ptmass(3,j) - dvx = vxi - vxyz_ptmass(1,j) - dvy = vyi - vxyz_ptmass(2,j) - dvz = vzi - vxyz_ptmass(3,j) - r2 = dx**2+dy**2+dz**2 - r = sqrt(r2) - mj = xyzmh_ptmass(4,j) - gravf = mj*(1./(r2*r)) - gtki = gtki + mj*(1./r) - gravfi(1) = gravfi(1) + dx*gravf - gravfi(2) = gravfi(2) + dy*gravf - gravfi(3) = gravfi(3) + dz*gravf - rdotv = dx*dvx + dy*dvy + dz*dvz - gravrdotv = gravrdotv + gravf*rdotv - enddo - om = om + gtki*mi - axi = axi + gravfi(1) - ayi = ayi + gravfi(2) - azi = azi + gravfi(3) - acc = sqrt(axi**2 + ayi**2 + azi**2) - v = sqrt(vxi**2 + vyi**2 + vzi**2) - Edot = Edot + mi*(v*acc - gravrdotv) - E = E + 0.5*mi*v**2 - gtki - enddo - - ds_init = eta_pert * abs(E/Edot) - om = om*0.5 - -end subroutine initial_int - -subroutine initial_int_bin(xyzmh_ptmass,fxyz_ptmass,vxyz_ptmass,group_info,om,i,j,ds_init) - use utils_kepler, only :extract_a_dot,extract_a,Espec - use part, only:igarg - real, intent(in) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) - real, intent(inout) :: fxyz_ptmass(:,:) - integer,intent(in) :: group_info(:,:) - real, intent(out) :: om,ds_init - integer, intent(in) :: i,j - real :: mi,mj,mu,dx,dy,dz,r,r2,ddr3 - real :: v,v2,dvx,dvy,dvz - real :: dax,day,daz,acc - real :: gravfi,gravfj,gtki - real :: semi,semidot - - om = 0. - - - - mi = xyzmh_ptmass(4,i) - mj = xyzmh_ptmass(4,j) - dx = xyzmh_ptmass(1,i) - xyzmh_ptmass(1,j) - dy = xyzmh_ptmass(2,i) - xyzmh_ptmass(2,j) - dz = xyzmh_ptmass(3,i) - xyzmh_ptmass(3,j) - dvx = vxyz_ptmass(1,i) - vxyz_ptmass(1,j) - dvy = vxyz_ptmass(2,i) - vxyz_ptmass(2,j) - dvz = vxyz_ptmass(3,i) - vxyz_ptmass(3,j) + if (present(ds_init) .and. .not.present(potonly)) then + f2i = fxi**2+fyi**2+fzi**2 + f2j = fxj**2+fyj**2+fzj**2 + dsi = sqrt(abs(gtki)/f2i) + dsj = sqrt(abs(gtkj)/f2j) + ds_init = 0.000125*min(dsi,dsj)*om + endif - r2 = dx**2+dy**2+dz**2 - r = sqrt(r2) - v2 = dvx**2 + dvy**2 + dvz**2 - v = sqrt(v2) - ddr3 = (1./(r2*r)) - gravfi = mj*ddr3 - gravfj = mi*ddr3 - gtki = mj*(1./r) +end subroutine get_force_TTL_bin - fxyz_ptmass(1,i) = fxyz_ptmass(1,i) - dx*gravfi - fxyz_ptmass(2,i) = fxyz_ptmass(2,i) - dy*gravfi - fxyz_ptmass(3,i) = fxyz_ptmass(3,i) - dz*gravfi - fxyz_ptmass(1,j) = fxyz_ptmass(1,j) + dx*gravfj - fxyz_ptmass(2,j) = fxyz_ptmass(2,j) + dy*gravfj - fxyz_ptmass(3,j) = fxyz_ptmass(3,j) + dz*gravfj - dax = fxyz_ptmass(1,i) - fxyz_ptmass(1,j) - day = fxyz_ptmass(2,i) - fxyz_ptmass(2,j) - daz = fxyz_ptmass(3,i) - fxyz_ptmass(3,j) +subroutine get_pot_subsys(n_group,nptmass,group_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) + use part, only: igarg,igcum + use io, only: id,master + integer, intent(in) :: n_group,nptmass + real, intent(inout) :: xyzmh_ptmass(:,:),fxyz_ptmass(:,:),gtgrad(:,:) + integer, intent(in) :: group_info(:,:) + real, intent(inout) :: epot_sinksink + integer :: i,start_id,end_id,gsize,prim,sec + real :: phitot + phitot = 0. + if (n_group>0) then + if(id==master) then + !$omp parallel do default(none)& + !$omp shared(xyzmh_ptmass,fxyz_ptmass)& + !$omp shared(group_info,gtgrad)& + !$omp private(i,start_id,end_id,gsize,prim,sec)& + !$omp reduction(+:phitot) + do i=1,n_group + start_id = group_info(igcum,i) + 1 + end_id = group_info(igcum,i+1) + gsize = (end_id - start_id) + 1 + if (gsize>2) then + call get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,phitot,start_id,end_id,.true.) + else + prim = group_info(igarg,start_id) + sec = group_info(igarg,end_id) + call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,phitot,prim,sec,.true.) + endif + enddo + !$omp end parallel do + endif + endif - acc = sqrt(dax**2 + day**2 + daz**2) - mu = mi*mj + epot_sinksink = epot_sinksink - phitot - call extract_a_dot(r2,r,mu,v2,v,acc,semidot) - call extract_a(r,mu,v2,semi) - ds_init = eta_pert * abs(semi/semidot) - om = gtki*mi - print*,abs(semidot/semi),5.e-5/(r2*acc/(mi+mj)),ds_init +end subroutine get_pot_subsys -end subroutine initial_int_bin end module sdar_group diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 54234da06..956b91db4 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -558,10 +558,10 @@ end subroutine substep !---------------------------------------------------------------- subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass, & dsdt_ptmass,dptmass,fsink_old,nbinmax,ibin_wake,gtgrad,group_info,nmatrix,n_group,n_ingroup,n_sing) - use part, only:isdead_or_accreted,igas,massoftype,fxyz_ptmass_sinksink + use part, only:isdead_or_accreted,igas,massoftype,fxyz_ptmass_sinksink,epot_sinksink use io, only:iverbose,id,master,iprint,warning,fatal use io_summary, only:summary_variable,iosumextr,iosumextt - use sdar_group, only:group_identify,evolve_groups + use sdar_group, only:group_identify,evolve_groups,get_pot_subsys use options, only:iexternalforce use externalforces, only:is_velocity_dependent real, intent(in) :: dtsph,time From ddb148fe9a65fbeef261d180ad97db79caa9a6b1 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Tue, 23 Apr 2024 14:13:39 +1000 Subject: [PATCH 22/45] fix substep with sub --- src/main/substepping.F90 | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 3e723361a..eaea883dd 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -557,6 +557,7 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vx use sdar_group, only:group_identify,evolve_groups,get_pot_subsys use options, only:iexternalforce use externalforces, only:is_velocity_dependent + use ptmass, only:dk,ck real, intent(in) :: dtsph,time integer, intent(in) :: npart,nptmass,ntypes real, intent(inout) :: dtextforce @@ -569,7 +570,7 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vx integer(kind=1), intent(in) :: nbinmax integer(kind=1), intent(inout) :: ibin_wake(:) integer, intent(inout) :: n_ingroup,n_group,n_sing - logical :: extf_vdep_flag,done,last_step + logical :: extf_vdep_flag,done,last_step,accreted integer :: force_count,nsubsteps real :: timei,time_par,dt,t_end_step real :: dtextforce_min,pmassi @@ -610,7 +611,7 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vx call evolve_groups(n_group,nptmass,time_par,time_par+ck(1)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag,group_info=group_info) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,group_info=group_info) fsink_old = fxyz_ptmass call get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,fsink_old,force_count,group_info) @@ -621,10 +622,10 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vx call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag,group_info=group_info) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,group_info=group_info) call kick(dk(3),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass, & - dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink) + dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) if (iverbose >= 2 ) write(iprint,*) "nsubsteps : ",nsubsteps,"time,dt : ",timei,dt dtextforce_min = min(dtextforce_min,dtextforce) @@ -999,7 +1000,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, real :: fextx,fexty,fextz,xi,yi,zi,pmassi,damp_fac real :: fonrmaxi,phii,dtphi2i real :: dkdt,extrapfac - logical :: extrap,last + logical :: extrap,last,wsub if(present(fsink_old)) then fsink_old = fxyz_ptmass From fde336c27951fd5a896fc8730d812cfb5a5bf3b0 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 24 Apr 2024 10:59:12 +1000 Subject: [PATCH 23/45] fix bad reduction in the group potential calculation --- src/main/sdar_group.f90 | 11 ++++++----- src/main/substepping.F90 | 5 +++-- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index 81c015365..9f04da39a 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -16,7 +16,7 @@ module sdar_group real, parameter :: eta_pert = 20 real, parameter :: time_error = 2.5e-14 real, parameter :: max_step = 100000000 - real, parameter, public :: r_neigh = 0.0001 + real, parameter, public :: r_neigh = 0.001 real, public :: t_crit = 1.e-9 real, public :: C_bin = 0.02 real, public :: r_search = 100.*r_neigh @@ -700,26 +700,27 @@ subroutine get_pot_subsys(n_group,nptmass,group_info,xyzmh_ptmass,fxyz_ptmass,gt integer, intent(in) :: group_info(:,:) real, intent(inout) :: epot_sinksink integer :: i,start_id,end_id,gsize,prim,sec - real :: phitot + real :: phitot,phigroup phitot = 0. if (n_group>0) then if(id==master) then !$omp parallel do default(none)& !$omp shared(xyzmh_ptmass,fxyz_ptmass)& !$omp shared(group_info,gtgrad)& - !$omp private(i,start_id,end_id,gsize,prim,sec)& + !$omp private(i,start_id,end_id,gsize,prim,sec,phigroup)& !$omp reduction(+:phitot) do i=1,n_group start_id = group_info(igcum,i) + 1 end_id = group_info(igcum,i+1) gsize = (end_id - start_id) + 1 if (gsize>2) then - call get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,phitot,start_id,end_id,.true.) + call get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,phigroup,start_id,end_id,.true.) else prim = group_info(igarg,start_id) sec = group_info(igarg,end_id) - call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,phitot,prim,sec,.true.) + call get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,phigroup,prim,sec,.true.) endif + phitot = phitot + phigroup enddo !$omp end parallel do endif diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index eaea883dd..4a98f3bf7 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -604,12 +604,13 @@ subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vx ! Group all the ptmass in the system in multiple small group for regularization ! call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) - !call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - ! vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,ck(1),dk(2),force_count,extf_vdep_flag,group_info=group_info) + call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) call evolve_groups(n_group,nptmass,time_par,time_par+ck(1)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,group_info=group_info) fsink_old = fxyz_ptmass From 5e0243f6672f4dac5cf90da7212948e5d85b9c15 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 24 Apr 2024 12:26:09 +1000 Subject: [PATCH 24/45] merge two substep subroutines and clean gradf routine --- src/main/ptmass.F90 | 246 ------------------------------ src/main/step_leapfrog.F90 | 17 +-- src/main/substepping.F90 | 303 +++++++++++-------------------------- 3 files changed, 91 insertions(+), 475 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 8385e0308..40bccb14d 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -46,7 +46,6 @@ module ptmass public :: init_ptmass, finish_ptmass public :: pt_write_sinkev, pt_close_sinkev public :: get_accel_sink_gas, get_accel_sink_sink - public :: get_gradf_sink_gas, get_gradf_sink_sink public :: merge_sinks public :: ptmass_kick, ptmass_drift,ptmass_vdependent_correction public :: ptmass_not_obscured @@ -551,251 +550,6 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin end subroutine get_accel_sink_sink -!---------------------------------------------------------------- -!+ -! get gradient correction of the force for FSI integrator (sink-gas) -!+ -!---------------------------------------------------------------- -subroutine get_gradf_sink_gas(nptmass,dt,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi, & - pmassi,fxyz_ptmass,fsink_old) - use kernel, only:kernel_softening,kernel_grad_soft,radkern - integer, intent(in) :: nptmass - real, intent(in) :: xi,yi,zi,hi,dt - real, intent(inout) :: fxi,fyi,fzi - real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) - real, intent(in) :: pmassi - real, intent(inout) :: fxyz_ptmass(4,nptmass) - real, intent(in) :: fsink_old(4,nptmass) - real :: gtmpxi,gtmpyi,gtmpzi - real :: dx,dy,dz,rr2,ddr,dr3,g11,g12,g21,g22,pmassj - real :: dfx,dfy,dfz,drdotdf - real :: hsoft,hsoft1,hsoft21,q2i,qi,psoft,fsoft,gsoft,gpref - integer :: j - - gtmpxi = 0. ! use temporary summation variable - gtmpyi = 0. ! (better for round-off, plus we need this bit of - gtmpzi = 0. - - do j=1,nptmass - dx = xi - xyzmh_ptmass(1,j) - dy = yi - xyzmh_ptmass(2,j) - dz = zi - xyzmh_ptmass(3,j) - dfx = fxi - fsink_old(1,j) - dfy = fyi - fsink_old(2,j) - dfz = fzi - fsink_old(3,j) - pmassj = xyzmh_ptmass(4,j) - hsoft = xyzmh_ptmass(ihsoft,j) - if (hsoft > 0.0) hsoft = max(hsoft,hi) - if (pmassj < 0.0) cycle - - rr2 = dx*dx + dy*dy + dz*dz + epsilon(rr2) - drdotdf = dx*dfx + dy*dfy + dz*dfz + epsilon(drdotdf) - ddr = 1./sqrt(rr2) - if (rr2 < (radkern*hsoft)**2) then - ! - ! if the sink particle is given a softening length, soften the - ! force and potential if r < radkern*hsoft - ! - hsoft1 = 1.0/hsoft - hsoft21= hsoft1**2 - q2i = rr2*hsoft21 - qi = sqrt(q2i) - call kernel_softening(q2i,qi,psoft,fsoft) - - gpref = ((dt**2)/24.)*hsoft21 - - ! first grad term of gas due to point mass particle - g11 = pmassj*fsoft*ddr - - ! first grad term of sink from gas - g21 = pmassi*fsoft*ddr - - call kernel_grad_soft(q2i,qi,gsoft) - - dr3 = ddr*ddr*ddr - - ! Second grad term of gas due to point mass particle - g12 = pmassj*gsoft*dr3*drdotdf - - ! Second grad term of sink from gas - g22 = pmassi*gsoft*dr3*drdotdf - - gtmpxi = gtmpxi - gpref*(dfx*g11+dx*g12) - gtmpyi = gtmpyi - gpref*(dfy*g11+dy*g12) - gtmpzi = gtmpzi - gpref*(dfz*g11+dz*g12) - - - else - ! no softening on the sink-gas interaction - dr3 = ddr*ddr*ddr - - gpref = ((dt**2)/24.) - - ! first grad term of gas due to point mass particle - g11 = pmassj*dr3 - - ! first grad term of sink from gas - g21 = pmassi*dr3 - - ! first grad term of gas due to point mass particle - g12 = -3.*pmassj*dr3*ddr*ddr*drdotdf - - ! first grad term of sink from gas - g22 = -3.*pmassi*dr3*ddr*ddr*drdotdf - - - gtmpxi = gtmpxi - gpref*(dfx*g11+dx*g12) - gtmpyi = gtmpyi - gpref*(dfy*g11+dy*g12) - gtmpzi = gtmpzi - gpref*(dfz*g11+dz*g12) - endif - - ! backreaction of gas onto sink - fxyz_ptmass(1,j) = fxyz_ptmass(1,j) + gpref*(dfx*g21 + dx*g22) - fxyz_ptmass(2,j) = fxyz_ptmass(2,j) + gpref*(dfy*g21 + dy*g22) - fxyz_ptmass(3,j) = fxyz_ptmass(3,j) + gpref*(dfz*g21 + dz*g22) - enddo - ! - ! add temporary sums to existing force on gas particle - ! - fxi = fxi + gtmpxi - fyi = fyi + gtmpyi - fzi = fzi + gtmpzi - -end subroutine get_gradf_sink_gas - -!---------------------------------------------------------------- -!+ -! get gradient correction of the force for FSI integrator (sink-gas) -!+ -!---------------------------------------------------------------- -subroutine get_gradf_sink_sink(nptmass,dt,xyzmh_ptmass,fxyz_ptmass,fsink_old,group_info) - use kernel, only:kernel_softening,kernel_grad_soft,radkern - use part, only:igarg,igid - integer, intent(in) :: nptmass - real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) - real, intent(inout) :: fxyz_ptmass(4,nptmass) - real, intent(in) :: fsink_old(4,nptmass) - real, intent(in) :: dt - integer, optional, intent(in) :: group_info(:,:) - real :: xi,yi,zi,pmassi,pmassj,fxi,fyi,fzi,gxi,gyi,gzi - real :: ddr,dx,dy,dz,dfx,dfy,dfz,drdotdf,rr2,dr3,g1,g2 - real :: hsoft1,hsoft21,q2i,qi,psoft,fsoft,gsoft - real :: gpref - integer :: i,j,k,l,gidi,gidj - logical :: subsys - - if (present(group_info)) then - subsys = .true. - else - subsys=.false. - endif - - if (nptmass <= 1) return - if (h_soft_sinksink > 0.) then - hsoft1 = 1.0/h_soft_sinksink - hsoft21= hsoft1**2 - else - hsoft1 = 0. ! to avoid compiler warnings - hsoft21 = 0. - endif - ! - !--compute N^2 gradf on point mass particles due to each other - ! - !$omp parallel do default(none) & - !$omp shared(nptmass,xyzmh_ptmass,fxyz_ptmass,fsink_old,group_info) & - !$omp shared(h_soft_sinksink,hsoft21,dt,subsys) & - !$omp private(i,j,xi,yi,zi,pmassi,pmassj) & - !$omp private(gidi,gidj) & - !$omp private(dx,dy,dz,dfx,dfy,dfz,drdotdf,rr2,ddr,dr3,g1,g2) & - !$omp private(fxi,fyi,fzi,gxi,gyi,gzi,gpref) & - !$omp private(q2i,qi,psoft,fsoft,gsoft) - do k=1,nptmass - if (subsys) then - i = group_info(igarg,k) - gidi = group_info(igid,k) - else - i = k - endif - xi = xyzmh_ptmass(1,i) - yi = xyzmh_ptmass(2,i) - zi = xyzmh_ptmass(3,i) - pmassi = xyzmh_ptmass(4,i) - if (pmassi < 0.) cycle - fxi = fsink_old(1,i) - fyi = fsink_old(2,i) - fzi = fsink_old(3,i) - gxi = 0. - gyi = 0. - gzi = 0. - do l=1,nptmass - if (subsys) then - j = group_info(igarg,l) - gidj = group_info(igid,l) - if (gidi==gidj) cycle - else - j = l - endif - if (i==j) cycle - dx = xi - xyzmh_ptmass(1,j) - dy = yi - xyzmh_ptmass(2,j) - dz = zi - xyzmh_ptmass(3,j) - dfx = fxi - fsink_old(1,j) - dfy = fyi - fsink_old(2,j) - dfz = fzi - fsink_old(3,j) - pmassj = xyzmh_ptmass(4,j) - if (pmassj < 0.) cycle - - rr2 = dx*dx + dy*dy + dz*dz + epsilon(rr2) - drdotdf = dx*dfx + dy*dfy + dz*dfz - ddr = 1./sqrt(rr2) - - gpref = pmassj*((dt**2)/24.) - - if (rr2 < (radkern*h_soft_sinksink)**2) then - ! - ! if the sink particle is given a softening length, soften the - ! force and potential if r < radkern*h_soft_sinksink - ! - q2i = rr2*hsoft21 - qi = sqrt(q2i) - call kernel_softening(q2i,qi,psoft,fsoft) ! Note: psoft < 0 - - - ! gradf part 1 of sink1 from sink2 - g1 = fsoft*hsoft21*ddr - - call kernel_grad_soft(q2i,qi,gsoft) - - dr3 = ddr*ddr*ddr - - ! gradf part 2 of sink1 from sink2 - g2 = gsoft*hsoft21*dr3*drdotdf - gxi = gxi - gpref*(dfx*g1 + dx*g2) - gyi = gyi - gpref*(dfy*g1 + dy*g2) - gzi = gzi - gpref*(dfz*g1 + dz*g2) - - else - ! no softening on the sink-sink interaction - dr3 = ddr*ddr*ddr - - ! gradf part 1 of sink1 from sink2 - g1 = dr3 - ! gradf part 2 of sink1 from sink2 - g2 = -3.*dr3*ddr*ddr*drdotdf - gxi = gxi - gpref*(dfx*g1 + dx*g2) - gyi = gyi - gpref*(dfy*g1 + dy*g2) - gzi = gzi - gpref*(dfz*g1 + dz*g2) - endif - enddo - ! - !--store sink-sink forces (only) - ! - fxyz_ptmass(1,i) = fxyz_ptmass(1,i) + gxi - fxyz_ptmass(2,i) = fxyz_ptmass(2,i) + gyi - fxyz_ptmass(3,i) = fxyz_ptmass(3,i) + gzi - enddo -!$omp end parallel do -end subroutine get_gradf_sink_sink !---------------------------------------------------------------- !+ ! Update position of sink particles if they cross the periodic boundary diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index efb70bb49..f57331408 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -126,9 +126,8 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use damping, only:idamp use cons2primsolver, only:conservative2primitive,primitive2conservative use eos, only:equationofstate - use ptmass, only:use_regnbody use substepping, only:substep,substep_gr, & - substep_sph_gr,substep_sph,step_extern_subsys + substep_sph_gr,substep_sph integer, intent(inout) :: npart integer, intent(in) :: nactive @@ -250,15 +249,11 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) endif else if (nptmass > 0 .or. iexternalforce > 0 .or. h2chemistry .or. cooling_in_step .or. idamp > 0) then - if (use_regnbody) then - call step_extern_subsys(dtextforce,dtsph,t,npart,ntypes,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dptmass,fsink_old,nbinmax,ibin_wake, & - gtgrad,group_info,nmatrix,n_group,n_ingroup,n_sing) - else - call substep(npart,ntypes,nptmass,dtsph,dtextforce,t,xyzh,vxyzu,& - fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,& - dptmass,fsink_old,nbinmax,ibin_wake) - endif + + call substep(npart,ntypes,nptmass,dtsph,dtextforce,t,xyzh,vxyzu,& + fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,& + dptmass,fsink_old,nbinmax,ibin_wake,gtgrad,group_info, & + nmatrix,n_group,n_ingroup,n_sing) else call substep_sph(dtsph,npart,xyzh,vxyzu) endif diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 4a98f3bf7..42b2deaaf 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -34,7 +34,6 @@ module substepping implicit none - public :: step_extern_subsys public :: substep_gr public :: substep_sph public :: substep_sph_gr @@ -427,22 +426,26 @@ end subroutine substep_sph !+ !---------------------------------------------------------------- subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & - xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dptmass, & - fsink_old,nbinmax,ibin_wake) + xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dptmass, & + fsink_old,nbinmax,ibin_wake,gtgrad,group_info,nmatrix, & + n_group,n_ingroup,n_sing) use io, only:iverbose,id,master,iprint,fatal use options, only:iexternalforce use part, only:fxyz_ptmass_sinksink use io_summary, only:summary_variable,iosumextr,iosumextt use externalforces, only:is_velocity_dependent - use ptmass, only:use_fourthorder,ck,dk + use ptmass, only:use_fourthorder,use_regnbody,ck,dk + use sdar_group, only:group_identify,evolve_groups integer, intent(in) :: npart,ntypes,nptmass + integer, intent(inout) :: n_group,n_ingroup,n_sing + integer, intent(inout) :: group_info(:,:) real, intent(in) :: dtsph,time real, intent(inout) :: dtextforce real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) - real, intent(inout) :: dptmass(:,:),fsink_old(:,:) + real, intent(inout) :: dptmass(:,:),fsink_old(:,:),gtgrad(:,:) integer(kind=1), intent(in) :: nbinmax - integer(kind=1), intent(inout) :: ibin_wake(:) + integer(kind=1), intent(inout) :: ibin_wake(:),nmatrix(nptmass,nptmass) logical :: extf_vdep_flag,done,last_step,accreted integer :: force_count,nsubsteps real :: timei,time_par,dt,t_end_step @@ -481,28 +484,57 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & ! call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass) + if (use_regnbody) then + call evolve_groups(n_group,nptmass,time_par,time_par+ck(1)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) - call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) + + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,group_info=group_info) + else + call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass) + + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag) + endif if (use_fourthorder) then !! FSI 4th order scheme ! FSI extrapolation method (Omelyan 2006) - call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,fsink_old) - call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + if (use_regnbody) then + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,fsink_old,group_info) - call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass) + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + + call evolve_groups(n_group,nptmass,time_par,time_par+ck(2)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + + call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) + + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,group_info=group_info) + else + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,fsink_old) + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + + call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass) + + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag) + ! the last kick phase of the scheme will perform the accretion loop after velocity update + endif - call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag) - ! the last kick phase of the scheme will perform the accretion loop after velocity update call kick(dk(3),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & - fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) - if (accreted) then + fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) + + if (use_regnbody) then + call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag) + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag,group_info=group_info) + elseif (accreted) then + call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & + vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag) endif else !! standard leapfrog scheme @@ -542,122 +574,6 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & end subroutine substep - - !---------------------------------------------------------------- - !+ - ! This is the equivalent of the routine below with no cooling - ! and external forces except ptmass with subsystems algorithms.. - !+ - !---------------------------------------------------------------- -subroutine step_extern_subsys(dtextforce,dtsph,time,npart,ntypes,nptmass,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass, & - dsdt_ptmass,dptmass,fsink_old,nbinmax,ibin_wake,gtgrad,group_info,nmatrix,n_group,n_ingroup,n_sing) - use part, only:isdead_or_accreted,igas,massoftype,fxyz_ptmass_sinksink,epot_sinksink - use io, only:iverbose,id,master,iprint,warning,fatal - use io_summary, only:summary_variable,iosumextr,iosumextt - use sdar_group, only:group_identify,evolve_groups,get_pot_subsys - use options, only:iexternalforce - use externalforces, only:is_velocity_dependent - use ptmass, only:dk,ck - real, intent(in) :: dtsph,time - integer, intent(in) :: npart,nptmass,ntypes - real, intent(inout) :: dtextforce - real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fext(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(4,nptmass) - real, intent(inout) :: dptmass(:,:) - real, intent(inout) :: fsink_old(4,nptmass),dsdt_ptmass(3,nptmass),gtgrad(3,nptmass) - integer, intent(inout) :: group_info(3,nptmass) - integer(kind=1), intent(inout) :: nmatrix(nptmass,nptmass) - integer(kind=1), intent(in) :: nbinmax - integer(kind=1), intent(inout) :: ibin_wake(:) - integer, intent(inout) :: n_ingroup,n_group,n_sing - logical :: extf_vdep_flag,done,last_step,accreted - integer :: force_count,nsubsteps - real :: timei,time_par,dt,t_end_step - real :: dtextforce_min,pmassi - - ! - ! determine whether or not to use substepping - ! - if (dtextforce < dtsph) then - dt = dtextforce - last_step = .false. - else - dt = dtsph - last_step = .true. - endif - - timei = time - time_par = time - extf_vdep_flag = is_velocity_dependent(iexternalforce) - pmassi = massoftype(igas) - t_end_step = timei + dtsph - nsubsteps = 0 - dtextforce_min = huge(dt) - done = .false. - - substeps: do while (timei <= t_end_step .and. .not.done) - timei = timei + dt - if (abs(dt) < tiny(0.)) call fatal('step_extern','dt <= 0 in sink-gas substepping',var='dt',val=dt) - force_count = 0 - nsubsteps = nsubsteps + 1 - ! - ! Group all the ptmass in the system in multiple small group for regularization - ! - call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,nmatrix) - - call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - - call evolve_groups(n_group,nptmass,time_par,time_par+ck(1)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) - - call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) - - call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,group_info=group_info) - fsink_old = fxyz_ptmass - call get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,fsink_old,force_count,group_info) - - call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) - - call evolve_groups(n_group,nptmass,time_par,time_par+ck(2)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) - - call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) - - call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & - vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,group_info=group_info) - - call kick(dk(3),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass, & - dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) - if (iverbose >= 2 ) write(iprint,*) "nsubsteps : ",nsubsteps,"time,dt : ",timei,dt - - dtextforce_min = min(dtextforce_min,dtextforce) - - if (last_step) then - done = .true. - else - dt = dtextforce - if (timei + dt > t_end_step) then - dt = t_end_step - timei - last_step = .true. - endif - endif - enddo substeps - - - if (nsubsteps > 1) then - if (iverbose>=1 .and. id==master) then - write(iprint,"(a,i6,a,f8.2,a,es10.3,a,es10.3)") & - ' using ',nsubsteps,' substeps (dthydro/dtextf = ',dtsph/dtextforce_min,'), dt = ',dtextforce_min,' dtsph = ',dtsph - endif - call summary_variable('ext',iosumextr ,nsubsteps,dtsph/dtextforce_min) - call summary_variable('ext',iosumextt ,nsubsteps,dtextforce_min,1.0/dtextforce_min) - endif - - -end subroutine step_extern_subsys - - - - !---------------------------------------------------------------- !+ ! drift routine for the whole system (part and ptmass) @@ -711,7 +627,6 @@ subroutine drift(cki,dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vx end subroutine drift - !---------------------------------------------------------------- !+ ! kick routine for the whole system (part and ptmass) @@ -894,68 +809,6 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, end subroutine kick - !---------------------------------------------------------------- - !+ - ! grad routine for the 4th order scheme (FSI) - !+ - !---------------------------------------------------------------- - - -subroutine get_gradf_4th(nptmass,npart,pmassi,dt,xyzh,fext,xyzmh_ptmass,fxyz_ptmass,fsink_old,force_count,group_info) - use dim, only:maxptmass - use ptmass, only:get_gradf_sink_gas,get_gradf_sink_sink,use_regnbody - use mpiutils, only:reduce_in_place_mpi - use io, only:id,master - integer, intent(in) :: nptmass,npart - integer, intent(inout) :: force_count - real, intent(inout) :: xyzh(:,:),fext(3,npart) - real, intent(inout) :: xyzmh_ptmass(:,:),fxyz_ptmass(4,nptmass) - real, intent(in) :: fsink_old(4,nptmass) - real, intent(inout) :: dt - real, intent(in) :: pmassi - integer, optional, intent(in) :: group_info(:,:) - real :: fextx,fexty,fextz - integer :: i - - force_count = force_count + 1 - - if (nptmass>0) then - if(id==master) then - if(use_regnbody) then - call get_gradf_sink_sink(nptmass,dt,xyzmh_ptmass,fxyz_ptmass,fsink_old,group_info) - else - call get_gradf_sink_sink(nptmass,dt,xyzmh_ptmass,fxyz_ptmass,fsink_old) - endif - else - fxyz_ptmass(:,:) = 0. - endif - endif - - !$omp parallel default(none) & - !$omp shared(npart,nptmass,xyzh,xyzmh_ptmass,fext,dt,pmassi,fsink_old) & - !$omp private(fextx,fexty,fextz) & - !$omp reduction(+:fxyz_ptmass) - !$omp do - do i=1,npart - fextx = fext(1,i) - fexty = fext(2,i) - fextz = fext(3,i) - call get_gradf_sink_gas(nptmass,dt,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),& - xyzmh_ptmass,fextx,fexty,fextz,pmassi,fxyz_ptmass,fsink_old) - fext(1,i) = fext(1,i)+ fextx - fext(2,i) = fext(2,i)+ fexty - fext(3,i) = fext(3,i)+ fextz - enddo - !$omp enddo - !$omp end parallel - - if (nptmass > 0) then - call reduce_in_place_mpi('+',fxyz_ptmass(:,1:nptmass)) - !call reduce_in_place_mpi('+',dsdt_ptmass(:,1:nptmass)) - endif - -end subroutine get_gradf_4th - !---------------------------------------------------------------- !+ ! force routine for the whole system. First is computed the @@ -1012,7 +865,6 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, if(present(group_info)) then wsub = .true. - extrap = .false. endif @@ -1040,35 +892,50 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, if (nptmass>0) then if (id==master) then if (extrap) then - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + if(wsub) then + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass, & + extrapfac,fsink_old,group_info) + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass, & + extrapfac,fsink_old,group_info) + endif + else + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n, & dsdt_ptmass,extrapfac,fsink_old) - if (merge_n > 0) then - call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n, & dsdt_ptmass,extrapfac,fsink_old) + endif endif - elseif (wsub) then - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,group_info=group_info) - if (merge_n > 0) then - call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + else + if(wsub) then call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,group_info=group_info) + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass,group_info=group_info) - fxyz_ptmass_sinksink=fxyz_ptmass - dsdt_ptmass_sinksink=dsdt_ptmass - endif - else - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& - dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) - if (merge_n > 0) then - call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + fxyz_ptmass_sinksink=fxyz_ptmass + dsdt_ptmass_sinksink=dsdt_ptmass + if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf + endif + else call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,merge_ij) + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,& dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass) - fxyz_ptmass_sinksink=fxyz_ptmass - dsdt_ptmass_sinksink=dsdt_ptmass - if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf + fxyz_ptmass_sinksink=fxyz_ptmass + dsdt_ptmass_sinksink=dsdt_ptmass + if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf + endif endif endif else From 2b0a377bcf9197d68f7be2f5736d9ca21f6bef35 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 24 Apr 2024 12:35:35 +1000 Subject: [PATCH 25/45] add a check in checksetup for regularization --- src/main/checksetup.f90 | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index eec4f19f0..3999a05dc 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -433,6 +433,10 @@ subroutine check_setup(nerror,nwarn,restart) !--check Forward symplectic integration method imcompatiblity ! call check_vdep_extf (nwarn,iexternalforce) +! +!--check Regularization imcompatibility +! + call check_regnbody (nerror) if (.not.h2chemistry .and. maxvxyzu >= 4 .and. icooling == 3 .and. iexternalforce/=iext_corotate .and. nptmass==0) then if (dot_product(xcom,xcom) > 1.e-2) then @@ -1028,4 +1032,14 @@ subroutine check_vdep_extf(nwarn,iexternalforce) end subroutine check_vdep_extf +subroutine check_regnbody (nerror) + use ptmass, only:use_regnbody,use_fourthorder + integer, intent(inout) :: nerror + if (.not.(use_fourthorder .and. use_regnbody)) then + print "(/,a,/)","Error: TTL integration and regularization tools are not available without FSI. Turn off TTL..." + nerror = nerror + 1 + endif +end subroutine check_regnbody + + end module checksetup From d94c77128f9ed2494310a847c4c3ddb15b8e3fd1 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 24 Apr 2024 14:28:55 +1000 Subject: [PATCH 26/45] fix unused var and gtgrad deallocation --- src/main/energies.F90 | 2 +- src/main/part.F90 | 1 + src/main/sdar_group.f90 | 36 +++++++++++++++++++++++------------- 3 files changed, 25 insertions(+), 14 deletions(-) diff --git a/src/main/energies.F90 b/src/main/energies.F90 index 3cf29993d..b1907c602 100644 --- a/src/main/energies.F90 +++ b/src/main/energies.F90 @@ -603,7 +603,7 @@ subroutine compute_energies(t) erad = reduceall_mpi('+',erad) if (nptmass > 1) then if (use_regnbody) then - call get_pot_subsys(n_group,nptmass,group_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) + call get_pot_subsys(n_group,group_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) endif epot = epot + epot_sinksink endif diff --git a/src/main/part.F90 b/src/main/part.F90 index f9c026ddd..5b5ae5f18 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -579,6 +579,7 @@ subroutine deallocate_part if (allocated(ibin_sts)) deallocate(ibin_sts) if (allocated(group_info)) deallocate(group_info) if (allocated(nmatrix)) deallocate(nmatrix) + if (allocated(gtgrad)) deallocate(gtgrad) end subroutine deallocate_part diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index 9f04da39a..59b0cc04c 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -199,7 +199,7 @@ subroutine evolve_groups(n_group,nptmass,time,tnext,group_info,xyzmh_ptmass,vxyz if(id==master) then !$omp parallel do default(none)& !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass)& - !$omp shared(tnext,time,group_info,gtgrad)& + !$omp shared(tnext,time,group_info,gtgrad,n_group)& !$omp private(i,start_id,end_id,gsize) do i=1,n_group start_id = group_info(igcum,i) + 1 @@ -263,9 +263,9 @@ subroutine integrate_to_time(start_id,end_id,gsize,time,tnext,xyzmh_ptmass,vxyz_ do while (.true.) if (backup_flag) then - call backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,bdata) + call backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,bdata) else - call restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,group_info,tcoord,t_old,W,W_old,bdata) + call restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,tcoord,t_old,W,W_old,bdata) endif t_old = tcoord W_old = W @@ -386,9 +386,9 @@ end subroutine new_ds_sync_sup -subroutine backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ptmass,bdata) +subroutine backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,bdata) use part, only: igarg - real, intent(in) ::xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:) + real, intent(in) ::xyzmh_ptmass(:,:),vxyz_ptmass(:,:) integer,intent(in) :: group_info(:,:) real, intent(out) ::bdata(:) integer,intent(in) :: start_id,end_id @@ -408,9 +408,9 @@ subroutine backup_data(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,fxyz_ end subroutine backup_data -subroutine restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,group_info,tcoord,t_old,W,W_old,bdata) +subroutine restore_state(start_id,end_id,xyzmh_ptmass,vxyz_ptmass,group_info,tcoord,t_old,W,W_old,bdata) use part, only: igarg - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) integer,intent(in) :: group_info(:,:) real, intent(out) :: tcoord,W real, intent(in) :: t_old,W_old @@ -567,10 +567,20 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id integer, intent(in) :: s_id,e_id logical, optional, intent(in) :: potonly real, optional, intent(out) :: ds_init - real :: mi,mj,xi,yi,zi,dx,dy,dz,r2,ddr,ddr3 + real :: mi,mj,xi,yi,zi,dx,dy,dz,r2,ddr,ddr3,dt_init real :: gravf,gtki,gravfi(3),gtgradi(3),f2 integer :: i,j,k,l + logical :: init om = 0. + dt_init = 0. + + + if(present(ds_init)) then + init = .true. + ds_init = 0. + else + init = .false. + endif do k=s_id,e_id @@ -617,17 +627,17 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,fxyz_ptmass,gtgrad,om,s_id,e_id gtgrad(3,i) = gtgradi(3) endif - if (present(ds_init)) then + if (init) then f2 = gravfi(1)**2+gravfi(2)**2+gravfi(3)**2 if (f2 > 0.) then - ds_init = min(ds_init,0.00002*sqrt(abs(gtki)/f2)) + dt_init = min(dt_init,0.00002*sqrt(abs(gtki)/f2)) endif endif om = om + gtki*mi enddo om = om*0.5 - if(present(ds_init)) ds_init = ds_init/om + if(init) ds_init = dt_init/om end subroutine get_force_TTL @@ -692,10 +702,10 @@ subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,i,j,potonly,ds_i end subroutine get_force_TTL_bin -subroutine get_pot_subsys(n_group,nptmass,group_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) +subroutine get_pot_subsys(n_group,group_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epot_sinksink) use part, only: igarg,igcum use io, only: id,master - integer, intent(in) :: n_group,nptmass + integer, intent(in) :: n_group real, intent(inout) :: xyzmh_ptmass(:,:),fxyz_ptmass(:,:),gtgrad(:,:) integer, intent(in) :: group_info(:,:) real, intent(inout) :: epot_sinksink From e9e8481b522b856d77e9587540e46b8155b0c106 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 24 Apr 2024 14:32:52 +1000 Subject: [PATCH 27/45] wrong size of gas sphere in starcluster setup --- src/setup/setup_starcluster.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/setup/setup_starcluster.f90 b/src/setup/setup_starcluster.f90 index 35c099017..0c5d3c385 100644 --- a/src/setup/setup_starcluster.f90 +++ b/src/setup/setup_starcluster.f90 @@ -132,7 +132,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! setup initial sphere of particles to prevent initialisation problems ! psep = 1.0 - call set_sphere('cubic',id,master,0.,0.01,psep,hfact,npart,xyzh) + call set_sphere('cubic',id,master,0.,10.,psep,hfact,npart,xyzh) vxyzu(4,:) = 5.317e-4 npartoftype(igas) = npart From 136e2a348a9e4d2c46f4fe8848b549d20a482019 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 24 Apr 2024 14:38:56 +1000 Subject: [PATCH 28/45] fix checksetup regularization --- src/main/checksetup.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index 3999a05dc..cf6d00364 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -1035,7 +1035,7 @@ end subroutine check_vdep_extf subroutine check_regnbody (nerror) use ptmass, only:use_regnbody,use_fourthorder integer, intent(inout) :: nerror - if (.not.(use_fourthorder .and. use_regnbody)) then + if (use_regnbody .and. .not.(use_fourthorder)) then print "(/,a,/)","Error: TTL integration and regularization tools are not available without FSI. Turn off TTL..." nerror = nerror + 1 endif From 721402c60ca30e6fe0fac22fb0e734fd158e0178 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 24 Apr 2024 16:11:25 +1000 Subject: [PATCH 29/45] fix ifort comp error --- src/main/sdar_group.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/sdar_group.f90 b/src/main/sdar_group.f90 index 59b0cc04c..7132ffd32 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/sdar_group.f90 @@ -716,7 +716,7 @@ subroutine get_pot_subsys(n_group,group_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epo if(id==master) then !$omp parallel do default(none)& !$omp shared(xyzmh_ptmass,fxyz_ptmass)& - !$omp shared(group_info,gtgrad)& + !$omp shared(group_info,gtgrad,n_group)& !$omp private(i,start_id,end_id,gsize,prim,sec,phigroup)& !$omp reduction(+:phitot) do i=1,n_group From ea0452261c0a2631442d6e7e6d772977719d8167 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 24 Apr 2024 17:09:22 +1000 Subject: [PATCH 30/45] Change name sdar_group to subgroup for clarity --- build/Makefile | 2 +- src/main/energies.F90 | 2 +- src/main/initial.F90 | 2 +- src/main/{sdar_group.f90 => subgroup.f90} | 6 +++--- src/main/substepping.F90 | 5 +---- src/main/{utils_sdar.f90 => utils_subgroup.f90} | 4 ++-- 6 files changed, 9 insertions(+), 12 deletions(-) rename src/main/{sdar_group.f90 => subgroup.f90} (99%) rename src/main/{utils_sdar.f90 => utils_subgroup.f90} (95%) diff --git a/build/Makefile b/build/Makefile index 39dc74d0b..400e5c684 100644 --- a/build/Makefile +++ b/build/Makefile @@ -535,7 +535,7 @@ SOURCES= physcon.f90 ${CONFIG} ${SRCKERNEL} io.F90 units.f90 \ utils_deriv.f90 utils_implicit.f90 radiation_implicit.f90 ${SRCTURB} \ ${SRCINJECT_DEPS} wind_equations.f90 wind.F90 ${SRCINJECT} \ ${SRCKROME} memory.f90 ${SRCREADWRITE_DUMPS} \ - utils_sdar.f90 utils_kepler.f90 sdar_group.f90\ + utils_subgroup.f90 utils_kepler.f90 subgroup.f90\ quitdump.f90 ptmass.F90 \ readwrite_infile.F90 dens.F90 force.F90 deriv.F90 energies.F90 sort_particles.f90 \ utils_shuffleparticles.F90 evwrite.f90 substepping.F90 step_leapfrog.F90 writeheader.F90 ${SRCAN} step_supertimestep.F90 \ diff --git a/src/main/energies.F90 b/src/main/energies.F90 index b1907c602..80d0480b6 100644 --- a/src/main/energies.F90 +++ b/src/main/energies.F90 @@ -81,7 +81,7 @@ subroutine compute_energies(t) use options, only:iexternalforce,calc_erot,alpha,ieos,use_dustfrac use mpiutils, only:reduceall_mpi use ptmass, only:get_accel_sink_gas,use_regnbody - use sdar_group, only:get_pot_subsys + use subgroup, only:get_pot_subsys use viscosity, only:irealvisc,shearfunc use nicil, only:nicil_update_nimhd,nicil_get_halldrift,nicil_get_ambidrift, & use_ohm,use_hall,use_ambi,n_data_out,n_warn,eta_constant diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 126010b75..f009025d2 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -212,7 +212,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use checkconserved, only:get_conserv,etot_in,angtot_in,totmom_in,mdust_in use fileutils, only:make_tags_unique use damping, only:idamp - use sdar_group, only:group_identify + use subgroup, only:group_identify character(len=*), intent(in) :: infile character(len=*), intent(out) :: logfile,evfile,dumpfile logical, intent(in), optional :: noread diff --git a/src/main/sdar_group.f90 b/src/main/subgroup.f90 similarity index 99% rename from src/main/sdar_group.f90 rename to src/main/subgroup.f90 index 7132ffd32..c2c0ed649 100644 --- a/src/main/sdar_group.f90 +++ b/src/main/subgroup.f90 @@ -1,4 +1,4 @@ -module sdar_group +module subgroup ! ! this module contains everything to identify ! and integrate regularized groups... @@ -7,7 +7,7 @@ module sdar_group ! ! :Owner: Yann BERNARD ! - use utils_sdar + use utils_subgroup implicit none public :: group_identify public :: evolve_groups @@ -743,4 +743,4 @@ subroutine get_pot_subsys(n_group,group_info,xyzmh_ptmass,fxyz_ptmass,gtgrad,epo end subroutine get_pot_subsys -end module sdar_group +end module subgroup diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 26e66f970..5f8368823 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -434,7 +434,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & use io_summary, only:summary_variable,iosumextr,iosumextt use externalforces, only:is_velocity_dependent use ptmass, only:use_fourthorder,use_regnbody,ck,dk - use sdar_group, only:group_identify,evolve_groups + use subgroup, only:group_identify,evolve_groups integer, intent(in) :: npart,ntypes,nptmass integer, intent(inout) :: n_group,n_ingroup,n_sing integer, intent(inout) :: group_info(:,:) @@ -534,9 +534,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(3),force_count,extf_vdep_flag) endif - else !! standard leapfrog scheme - ! the last kick phase of the scheme will perform the accretion loop after velocity update call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext, & fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) @@ -544,7 +542,6 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag) endif - endif dtextforce_min = min(dtextforce_min,dtextforce) diff --git a/src/main/utils_sdar.f90 b/src/main/utils_subgroup.f90 similarity index 95% rename from src/main/utils_sdar.f90 rename to src/main/utils_subgroup.f90 index 7b0ce4401..ffbecf1a1 100644 --- a/src/main/utils_sdar.f90 +++ b/src/main/utils_subgroup.f90 @@ -1,4 +1,4 @@ -module utils_sdar +module utils_subgroup implicit none integer, parameter :: ck_size = 8 real,dimension(8),parameter :: cks=(/0.3922568052387800,0.5100434119184585,-0.4710533854097566,& @@ -15,4 +15,4 @@ module utils_sdar contains -end module utils_sdar +end module utils_subgroup From 270c1703ed31e90c84b2306e45967f4ea4f408d8 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Wed, 24 Apr 2024 18:05:02 +1000 Subject: [PATCH 31/45] fix wrong value in if statement (forgotten merge conflict) --- src/main/substepping.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 5f8368823..c99964510 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -795,7 +795,7 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, call summary_accrete_fail(nfail) call summary_accrete(nptmass) ! only write to .ev during substeps if no gas particles present - if (npart==-1) call pt_write_sinkev(nptmass,timei,xyzmh_ptmass,vxyz_ptmass, & + if (npart==0) call pt_write_sinkev(nptmass,timei,xyzmh_ptmass,vxyz_ptmass, & fxyz_ptmass,fxyz_ptmass_sinksink) endif endif From 49e80df15b6b128bfd0d9c49646058a00385334b Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 29 Apr 2024 10:10:05 +1000 Subject: [PATCH 32/45] fix uninitialised variable in kick loop ( must also be fixed in the master repo) --- src/main/substepping.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index c99964510..c226fa977 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -706,6 +706,11 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, nlive = 0 ibin_wakei = 0 dptmass(:,1:nptmass) = 0. + fxi = 0. + fyi = 0. + fzi = 0. + pmassi = 0. + itype = 0 !$omp parallel default(none) & !$omp shared(maxp,maxphase) & !$omp shared(npart,xyzh,vxyzu,fext,dkdt,iphase,ntypes,massoftype,timei,nptmass,sts_it_n) & From de3b8e41b6d497f690140948a603dfe021311239 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 29 Apr 2024 10:43:59 +1000 Subject: [PATCH 33/45] fix uninitialised part2 --- src/main/substepping.F90 | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index c226fa977..c99964510 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -706,11 +706,6 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, nlive = 0 ibin_wakei = 0 dptmass(:,1:nptmass) = 0. - fxi = 0. - fyi = 0. - fzi = 0. - pmassi = 0. - itype = 0 !$omp parallel default(none) & !$omp shared(maxp,maxphase) & !$omp shared(npart,xyzh,vxyzu,fext,dkdt,iphase,ntypes,massoftype,timei,nptmass,sts_it_n) & From 10341b3d4865f5d3bd9668c40265238ee5403c84 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 29 Apr 2024 11:10:30 +1000 Subject: [PATCH 34/45] fix uninitialiased variable part 3 --- src/main/substepping.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index c99964510..58652a2a8 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -706,6 +706,11 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, nlive = 0 ibin_wakei = 0 dptmass(:,1:nptmass) = 0. + fxi = 0. + fyi = 0. + fzi = 0. + itype = iphase(igas) + pmassi = massoftype(igas) !$omp parallel default(none) & !$omp shared(maxp,maxphase) & !$omp shared(npart,xyzh,vxyzu,fext,dkdt,iphase,ntypes,massoftype,timei,nptmass,sts_it_n) & From 5f66895f1aac0b2e93737609a84b270317a071a1 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 29 Apr 2024 12:32:44 +1000 Subject: [PATCH 35/45] fix uninitialised part 4 --- src/main/substepping.F90 | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 58652a2a8..e6936340f 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -662,6 +662,7 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, itype = iphase(igas) pmassi = massoftype(igas) + accreted = .false. dkdt = dki*dt @@ -706,21 +707,17 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, nlive = 0 ibin_wakei = 0 dptmass(:,1:nptmass) = 0. - fxi = 0. - fyi = 0. - fzi = 0. - itype = iphase(igas) - pmassi = massoftype(igas) !$omp parallel default(none) & !$omp shared(maxp,maxphase) & !$omp shared(npart,xyzh,vxyzu,fext,dkdt,iphase,ntypes,massoftype,timei,nptmass,sts_it_n) & !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,f_acc) & !$omp shared(iexternalforce) & !$omp shared(nbinmax,ibin_wake) & - !$omp reduction(+:dptmass) & !$omp private(i,accreted,nfaili,fxi,fyi,fzi) & !$omp firstprivate(itype,pmassi,ibin_wakei) & - !$omp reduction(+:accretedmass,nfail,naccreted,nlive) + !$omp reduction(+:dptmass) & + !$omp reduction(+:accretedmass) & + !$omp reduction(+:nfail,naccreted,nlive) !$omp do accreteloop: do i=1,npart if (.not.isdead_or_accreted(xyzh(4,i))) then From 3646f1114b4fb867fb807d97c7b88fa5697db557 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 29 Apr 2024 12:40:25 +1000 Subject: [PATCH 36/45] fix uninitialised part 5.... --- src/main/substepping.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index e6936340f..ca40e3e92 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -662,7 +662,6 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, itype = iphase(igas) pmassi = massoftype(igas) - accreted = .false. dkdt = dki*dt From 55f23d5a3add6517a53624fdc20479497feadebd Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 30 Apr 2024 13:21:34 +0200 Subject: [PATCH 37/45] (CE-analysis) add radiation energy to thermal energy when using radiation --- src/main/ionization.f90 | 7 ++- src/utils/analysis_common_envelope.f90 | 69 ++++++++++++-------------- 2 files changed, 38 insertions(+), 38 deletions(-) diff --git a/src/main/ionization.f90 b/src/main/ionization.f90 index ebc536639..88f155561 100644 --- a/src/main/ionization.f90 +++ b/src/main/ionization.f90 @@ -338,13 +338,15 @@ end subroutine get_erec_components ! gas particle. Inputs and outputs in code units !+ !---------------------------------------------------------------- -subroutine calc_thermal_energy(particlemass,ieos,xyzh,vxyzu,presi,tempi,gamma,ethi) - use part, only:rhoh +subroutine calc_thermal_energy(particlemass,ieos,xyzh,vxyzu,presi,tempi,gamma,ethi,radprop) + use dim, only:do_radiation + use part, only:rhoh,iradxi use eos_idealplusrad, only:get_idealgasplusrad_tempfrompres,get_idealplusrad_enfromtemp use physcon, only:radconst,Rg use units, only:unit_density,unit_pressure,unit_ergg,unit_pressure integer, intent(in) :: ieos real, intent(in) :: particlemass,presi,tempi,xyzh(4),vxyzu(4),gamma + real, intent(in), optional :: radprop real, intent(out) :: ethi real :: hi,densi_cgs,mui @@ -357,6 +359,7 @@ subroutine calc_thermal_energy(particlemass,ieos,xyzh,vxyzu,presi,tempi,gamma,et ethi = particlemass * ethi / unit_ergg case default ! assuming internal energy = thermal energy ethi = particlemass * vxyzu(4) + if (do_radiation) ethi = ethi + particlemass*radprop(iradxi) end select end subroutine calc_thermal_energy diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 629645cb2..4386063b3 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -20,24 +20,26 @@ module analysis ! sortutils, table_utils, units, vectorutils ! - use part, only:xyzmh_ptmass,vxyz_ptmass,nptmass,poten,ihsoft,ihacc,& - rhoh,nsinkproperties,maxvxyzu,maxptmass,isdead_or_accreted - use units, only:print_units,umass,utime,udist,unit_ergg,unit_density,& - unit_pressure,unit_velocity,unit_Bfield,unit_energ - use physcon, only:gg,pi,c,Rg - use io, only:fatal - use prompting, only:prompt - use centreofmass, only:get_centreofmass, reset_centreofmass - use energies, only:compute_energies,ekin,etherm,epot,etot - use ptmass, only:get_accel_sink_gas,get_accel_sink_sink - use kernel, only:kernel_softening,radkern,wkern,cnormk - use eos, only:equationofstate,ieos,init_eos,X_in,Z_in,gmw,get_spsound,done_init_eos - use eos_gasradrec,only:irecomb - use eos_mesa, only:get_eos_kappa_mesa,get_eos_pressure_temp_mesa,& - get_eos_various_mesa,get_eos_pressure_temp_gamma1_mesa - use setbinary, only:Rochelobe_estimate,L1_point - use sortutils, only:set_r2func_origin,r2func_origin,indexxfunc - use table_utils, only:logspace + use part, only:xyzmh_ptmass,vxyz_ptmass,nptmass,poten,ihsoft,ihacc,& + rhoh,nsinkproperties,maxvxyzu,maxptmass,isdead_or_accreted + use dim, only:do_radiation + use units, only:print_units,umass,utime,udist,unit_ergg,unit_density,& + unit_pressure,unit_velocity,unit_Bfield,unit_energ + use physcon, only:gg,pi,c,Rg + use io, only:fatal + use prompting, only:prompt + use centreofmass, only:get_centreofmass, reset_centreofmass + use energies, only:compute_energies,ekin,etherm,epot,etot + use ptmass, only:get_accel_sink_gas,get_accel_sink_sink + use kernel, only:kernel_softening,radkern,wkern,cnormk + use ionization_mod,only:calc_thermal_energy + use eos, only:equationofstate,ieos,init_eos,X_in,Z_in,gmw,get_spsound,done_init_eos + use eos_gasradrec, only:irecomb + use eos_mesa, only:get_eos_kappa_mesa,get_eos_pressure_temp_mesa,& + get_eos_various_mesa,get_eos_pressure_temp_gamma1_mesa + use setbinary, only:Rochelobe_estimate,L1_point + use sortutils, only:set_r2func_origin,r2func_origin,indexxfunc + use table_utils, only:logspace implicit none character(len=20), parameter, public :: analysistype = 'common_envelope' integer :: analysis_to_perform @@ -623,9 +625,8 @@ end subroutine m_vs_t !+ !---------------------------------------------------------------- subroutine bound_mass(time,npart,particlemass,xyzh,vxyzu) - use part, only:eos_vars,itemp + use part, only:eos_vars,itemp,radprop use ptmass, only:get_accel_sink_gas - use ionization_mod, only:calc_thermal_energy use vectorutils, only:cross_product3D integer, intent(in) :: npart real, intent(in) :: time,particlemass @@ -702,7 +703,7 @@ subroutine bound_mass(time,npart,particlemass,xyzh,vxyzu) tempi = eos_vars(itemp,i) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) call cross_product3D(xyzh(1:3,i), particlemass * vxyzu(1:3,i), rcrossmv) ! Angular momentum w.r.t. CoM - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,gamma,ethi,radprop) etoti = ekini + epoti + ethi ! Overwrite etoti outputted by calc_gas_energies to use ethi instead of einti else ! Output 0 for quantities pertaining to accreted particles @@ -1382,7 +1383,7 @@ subroutine output_divv_files(time,dumpfile,npart,particlemass,xyzh,vxyzu) use eos_mesa, only:get_eos_kappa_mesa use mesa_microphysics, only:getvalue_mesa use sortutils, only:set_r2func_origin,r2func_origin,indexxfunc - use ionization_mod, only:calc_thermal_energy,ionisation_fraction + use ionization_mod, only:ionisation_fraction use dust_formation, only:psat_C,eps,set_abundances,mass_per_H, chemical_equilibrium_light, calc_nucleation!, Scrit !use dim, only:nElements integer, intent(in) :: npart @@ -1663,7 +1664,7 @@ subroutine track_particle(time,particlemass,xyzh,vxyzu) use part, only:eos_vars,itemp use eos, only:entropy use mesa_microphysics, only:getvalue_mesa - use ionization_mod, only:calc_thermal_energy,ionisation_fraction + use ionization_mod, only:ionisation_fraction real, intent(in) :: time,particlemass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) integer, parameter :: nparttotrack=10,ncols=17 @@ -1888,7 +1889,7 @@ end subroutine tconv_profile !---------------------------------------------------------------- subroutine recombination_tau(time,npart,particlemass,xyzh,vxyzu) use part, only:eos_vars,itemp - use ionization_mod, only:calc_thermal_energy,ionisation_fraction + use ionization_mod, only:ionisation_fraction integer, intent(in) :: npart real, intent(in) :: time,particlemass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) @@ -1979,7 +1980,6 @@ end subroutine recombination_tau !---------------------------------------------------------------- subroutine energy_hist(time,npart,particlemass,xyzh,vxyzu) use part, only:eos_vars,itemp - use ionization_mod, only:calc_thermal_energy integer, intent(in) :: npart real, intent(in) :: time,particlemass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) @@ -2044,7 +2044,7 @@ subroutine energy_profile(time,npart,particlemass,xyzh,vxyzu) use part, only:eos_vars,itemp use eos, only:entropy use mesa_microphysics, only:getvalue_mesa - use ionization_mod, only:calc_thermal_energy,ionisation_fraction + use ionization_mod, only:ionisation_fraction integer, intent(in) :: npart real, intent(in) :: time,particlemass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) @@ -2288,7 +2288,6 @@ end subroutine rotation_profile !---------------------------------------------------------------- subroutine velocity_histogram(time,num,npart,particlemass,xyzh,vxyzu) use part, only:eos_vars,itemp - use ionization_mod, only:calc_thermal_energy real, intent(in) :: time,particlemass integer, intent(in) :: npart,num real, intent(inout) :: xyzh(:,:),vxyzu(:,:) @@ -2571,7 +2570,6 @@ end subroutine planet_profile !+ !---------------------------------------------------------------- subroutine unbound_profiles(time,num,npart,particlemass,xyzh,vxyzu) - use ionization_mod, only:calc_thermal_energy integer, intent(in) :: npart,num real, intent(in) :: time,particlemass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) @@ -2690,7 +2688,7 @@ end subroutine unbound_profiles !+ !---------------------------------------------------------------- subroutine unbound_ionfrac(time,npart,particlemass,xyzh,vxyzu) - use ionization_mod, only:calc_thermal_energy,get_xion,ionisation_fraction + use ionization_mod, only:get_xion,ionisation_fraction integer, intent(in) :: npart real, intent(in) :: time,particlemass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) @@ -2766,7 +2764,7 @@ end subroutine unbound_ionfrac !---------------------------------------------------------------- subroutine unbound_temp(time,npart,particlemass,xyzh,vxyzu) use part, only:eos_vars,itemp - use ionization_mod, only:calc_thermal_energy,get_xion + use ionization_mod, only:get_xion integer, intent(in) :: npart real, intent(in) :: time,particlemass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) @@ -2840,7 +2838,7 @@ end subroutine unbound_temp !---------------------------------------------------------------- subroutine recombination_stats(time,num,npart,particlemass,xyzh,vxyzu) use part, only:eos_vars,itemp - use ionization_mod, only:calc_thermal_energy,ionisation_fraction + use ionization_mod, only:ionisation_fraction integer, intent(in) :: npart,num real, intent(in) :: time,particlemass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) @@ -3038,7 +3036,6 @@ end subroutine sink_properties subroutine env_binding_ene(npart,particlemass,xyzh,vxyzu) use part, only:eos_vars,itemp - use ionization_mod, only:calc_thermal_energy integer, intent(in) :: npart real, intent(in) :: particlemass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) @@ -3724,7 +3721,6 @@ end subroutine print_dump_numbers subroutine analyse_disk(num,npart,particlemass,xyzh,vxyzu) use part, only:eos_vars,itemp use extern_corotate, only:get_companion_force - use ionization_mod, only:calc_thermal_energy use vectorutils, only:cross_product3D integer, intent(in) :: num,npart real, intent(in) :: particlemass @@ -3855,14 +3851,14 @@ end subroutine get_gas_omega ! and internal energy of a gas particle. !+ !---------------------------------------------------------------- -subroutine calc_gas_energies(particlemass,poten,xyzh,vxyzu,xyzmh_ptmass,phii,epoti,ekini,einti,etoti) +subroutine calc_gas_energies(particlemass,poten,xyzh,vxyzu,radprop,xyzmh_ptmass,phii,epoti,ekini,einti,etoti) ! Warning: Do not sum epoti or etoti as it is to obtain a total energy; this would not give the correct ! total energy due to complications related to double-counting. use ptmass, only:get_accel_sink_gas - use part, only:nptmass + use part, only:nptmass,iradxi real, intent(in) :: particlemass real(4), intent(in) :: poten - real, dimension(4), intent(in) :: xyzh,vxyzu + real, intent(in) :: xyzh(:),vxyzu(:),radprop(:) real, dimension(5,nptmass), intent(in) :: xyzmh_ptmass real, intent(out) :: phii,epoti,ekini,einti,etoti real :: fxi,fyi,fzi @@ -3874,6 +3870,7 @@ subroutine calc_gas_energies(particlemass,poten,xyzh,vxyzu,xyzmh_ptmass,phii,epo epoti = 2.*poten + particlemass * phii ! For individual particles, need to multiply 2 to poten to get \sum_j G*mi*mj/r ekini = particlemass * 0.5 * dot_product(vxyzu(1:3),vxyzu(1:3)) einti = particlemass * vxyzu(4) + if (do_radiation) einti = einti + particlemass * radprop(iradxi) etoti = epoti + ekini + einti end subroutine calc_gas_energies From 11de37ef28b80213ee893a6e15681c9a9d00ad89 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 30 Apr 2024 13:36:51 +0200 Subject: [PATCH 38/45] (CE-analysis) add radprop to calc_gas_energy --- src/main/ionization.f90 | 2 +- src/utils/analysis_common_envelope.f90 | 44 ++++++++++++++------------ 2 files changed, 24 insertions(+), 22 deletions(-) diff --git a/src/main/ionization.f90 b/src/main/ionization.f90 index 88f155561..a2b914c5b 100644 --- a/src/main/ionization.f90 +++ b/src/main/ionization.f90 @@ -346,7 +346,7 @@ subroutine calc_thermal_energy(particlemass,ieos,xyzh,vxyzu,presi,tempi,gamma,et use units, only:unit_density,unit_pressure,unit_ergg,unit_pressure integer, intent(in) :: ieos real, intent(in) :: particlemass,presi,tempi,xyzh(4),vxyzu(4),gamma - real, intent(in), optional :: radprop + real, intent(in), optional :: radprop(:) real, intent(out) :: ethi real :: hi,densi_cgs,mui diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 4386063b3..5a1018278 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -21,7 +21,8 @@ module analysis ! use part, only:xyzmh_ptmass,vxyz_ptmass,nptmass,poten,ihsoft,ihacc,& - rhoh,nsinkproperties,maxvxyzu,maxptmass,isdead_or_accreted + rhoh,nsinkproperties,maxvxyzu,maxptmass,isdead_or_accreted,& + radprop use dim, only:do_radiation use units, only:print_units,umass,utime,udist,unit_ergg,unit_density,& unit_pressure,unit_velocity,unit_Bfield,unit_energ @@ -281,7 +282,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) xyz_a(1:3) = xyzh(1:3,i) - com_xyz(1:3) vxyz_a(1:3) = vxyzu(1:3,i) - com_vxyz(1:3) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) histogram_data(1:3,i) = xyzh(1:3,i) histogram_data(4,i) = distance(xyz_a(1:3)) histogram_data(5,i) = epoti + ekini @@ -697,13 +698,13 @@ subroutine bound_mass(time,npart,particlemass,xyzh,vxyzu) do i = 1,npart if (.not. isdead_or_accreted(xyzh(4,i))) then - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) call get_accel_sink_gas(nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),xyzmh_ptmass,dum1,dum2,dum3,phii) rhopart = rhoh(xyzh(4,i), particlemass) tempi = eos_vars(itemp,i) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) call cross_product3D(xyzh(1:3,i), particlemass * vxyzu(1:3,i), rcrossmv) ! Angular momentum w.r.t. CoM - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,gamma,ethi,radprop) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,gamma,ethi,radprop(:,i)) etoti = ekini + epoti + ethi ! Overwrite etoti outputted by calc_gas_energies to use ethi instead of einti else ! Output 0 for quantities pertaining to accreted particles @@ -859,7 +860,7 @@ subroutine calculate_energies(time,npart,particlemass,xyzh,vxyzu) jz = rcrossmv(3) encomp(ijz_tot) = encomp(ijz_tot) + jz - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) encomp(ipot_ps) = encomp(ipot_ps) + particlemass * phii @@ -1105,7 +1106,7 @@ subroutine roche_lobe_values(time,npart,particlemass,xyzh,vxyzu) call orbit_com(npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass,com_xyz,com_vxyz) do i=1,npart - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) sep1 = separation(xyzmh_ptmass(1:3,1),xyzh(1:3,i)) sep2 = separation(xyzmh_ptmass(1:3,2),xyzh(1:3,i)) @@ -1281,7 +1282,7 @@ subroutine star_stabilisation_suite(time,npart,particlemass,xyzh,vxyzu) rhopart = rhoh(xyzh(4,i), particlemass) totvol = totvol + particlemass / rhopart ! Sum "volume" of all particles virialpart = virialpart + particlemass * ( dot_product(fxyzu(1:3,i),xyzh(1:3,i)) + dot_product(vxyzu(1:3,i),vxyzu(1:3,i)) ) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) totekin = totekin + ekini totepot = totepot + 0.5*epoti ! Factor of 1/2 to correct for double counting if (rhopart > rho_surface) then @@ -1519,7 +1520,7 @@ subroutine output_divv_files(time,dumpfile,npart,particlemass,xyzh,vxyzu) case(1,9) ! Total energy (kin + pot + therm) rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum1) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum1) if (quantities_to_calculate(k)==1) then call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) quant(k,i) = (ekini + epoti + ethi) / particlemass ! Specific energy @@ -1727,7 +1728,7 @@ subroutine track_particle(time,particlemass,xyzh,vxyzu) endif ! MESA ENTROPY ! Si = entropy(rhopart*unit_density,ponrhoi*rhopart*unit_pressure,mu,ientropy,vxyzu(4,i)*unit_ergg,ierr) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) etoti = ekini + epoti + ethi call ionisation_fraction(rhopart*unit_density,eos_vars(itemp,i),X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) @@ -1927,7 +1928,7 @@ subroutine recombination_tau(time,npart,particlemass,xyzh,vxyzu) call get_eos_kappa_mesa(rho_part(i)*unit_density,eos_vars(itemp,i),kappa,kappat,kappar) kappa_part(i) = kappa ! In cgs units call ionisation_fraction(rho_part(i)*unit_density,eos_vars(itemp,i),X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) ! Calculate total energy + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) ! Calculate total energy call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rho_part(i),eos_vars(itemp,i),gamma,ethi) etoti = ekini + epoti + ethi if ((xh0 > recomb_th) .and. (.not. prev_recombined(i)) .and. (etoti < 0.)) then ! Recombination event and particle is still bound @@ -2006,7 +2007,7 @@ subroutine energy_hist(time,npart,particlemass,xyzh,vxyzu) do i=1,npart rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) if (ieos==10 .or. ieos==20) then call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) else @@ -2153,7 +2154,7 @@ subroutine energy_profile(time,npart,particlemass,xyzh,vxyzu) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) select case (iquantity) case(1) ! Energy - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) quant(i,1) = ekini + epoti + ethi case(2) ! Entropy @@ -2169,7 +2170,7 @@ subroutine energy_profile(time,npart,particlemass,xyzh,vxyzu) quant(i,1) = entropy(rhopart*unit_density,ponrhoi*rhopart*unit_pressure,mu,ientropy,ierr=ierr) endif case(3) ! Bernoulli energy (per unit mass) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) quant(i,1) = 0.5*dot_product(vxyzu(1:3,i),vxyzu(1:3,i)) + ponrhoi + vxyzu(4,i) + epoti/particlemass ! 1/2 v^2 + P/rho + phi case(4) ! Ion fraction call ionisation_fraction(rhopart*unit_density,eos_vars(itemp,i),X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) @@ -2301,7 +2302,7 @@ subroutine velocity_histogram(time,num,npart,particlemass,xyzh,vxyzu) do i = 1,npart rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) vr(i) = dot_product(xyzh(1:3,i),vxyzu(1:3,i)) / sqrt(dot_product(xyzh(1:3,i),xyzh(1:3,i))) @@ -2609,7 +2610,7 @@ subroutine unbound_profiles(time,num,npart,particlemass,xyzh,vxyzu) if (.not. isdead_or_accreted(xyzh(4,i))) then rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,gamma,ethi) etoti = ekini + epoti + ethi @@ -2717,7 +2718,7 @@ subroutine unbound_ionfrac(time,npart,particlemass,xyzh,vxyzu) do i=1,npart rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,gamma,ethi) etoti = ekini + epoti + ethi @@ -2787,7 +2788,7 @@ subroutine unbound_temp(time,npart,particlemass,xyzh,vxyzu) do i=1,npart rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),eos_vars(itemp,i),vxyzu(4,i)) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) etoti = ekini + epoti + ethi @@ -2857,7 +2858,7 @@ subroutine recombination_stats(time,num,npart,particlemass,xyzh,vxyzu) ! Calculate total energy rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) etoti = ekini + epoti + ethi @@ -3102,7 +3103,7 @@ subroutine bound_unbound_thermo(time,npart,particlemass,xyzh,vxyzu) call compute_energies(time) do i=1,npart - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) rhopart = rhoh(xyzh(4,i), particlemass) @@ -3447,7 +3448,7 @@ subroutine J_E_plane(num,npart,particlemass,xyzh,vxyzu) call get_centreofmass(com_xyz,com_vxyz,npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass) do i=1,npart - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,dum1,dum2,dum3,dum4,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,dum1,dum2,dum3,dum4,etoti) data(1,i) = etoti call cross_product3D(xyzh(1:3,i)-xyzmh_ptmass(1:3,1), vxyzu(1:3,i)-vxyz_ptmass(1:3,1), angmom_core) data(5:7,i) = angmom_core @@ -3996,7 +3997,8 @@ subroutine stellar_profile(time,ncols,particlemass,npart,xyzh,vxyzu,profile,simp kappa = 1. endif - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),& + xyzmh_ptmass,phii,epoti,ekini,einti,etoti) call ionisation_fraction(rhopart*unit_density,temp,X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) From c24c077b1d317b680e7bda61a321496a4ed166ff Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 30 Apr 2024 13:46:08 +0200 Subject: [PATCH 39/45] (CE-analysis) get rid of gammas in calc_therm_energy --- src/utils/analysis_common_envelope.f90 | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index ff567ae41..7edc51774 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -704,7 +704,7 @@ subroutine bound_mass(time,npart,particlemass,xyzh,vxyzu) tempi = eos_vars(itemp,i) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) call cross_product3D(xyzh(1:3,i), particlemass * vxyzu(1:3,i), rcrossmv) ! Angular momentum w.r.t. CoM - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,gamma,ethi,radprop(:,i)) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,ethi,radprop(:,i)) etoti = ekini + epoti + ethi ! Overwrite etoti outputted by calc_gas_energies to use ethi instead of einti else ! Output 0 for quantities pertaining to accreted particles @@ -1734,7 +1734,7 @@ subroutine track_particle(time,particlemass,xyzh,vxyzu) ! MESA ENTROPY ! Si = entropy(rhopart*unit_density,ponrhoi*rhopart*unit_pressure,mu,ientropy,vxyzu(4,i)*unit_ergg,ierr) call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) etoti = ekini + epoti + ethi call ionisation_fraction(rhopart*unit_density,eos_vars(itemp,i),X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) @@ -1934,7 +1934,7 @@ subroutine recombination_tau(time,npart,particlemass,xyzh,vxyzu) kappa_part(i) = kappa ! In cgs units call ionisation_fraction(rho_part(i)*unit_density,eos_vars(itemp,i),X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) ! Calculate total energy - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rho_part(i),eos_vars(itemp,i),gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rho_part(i),eos_vars(itemp,i),ethi) etoti = ekini + epoti + ethi if ((xh0 > recomb_th) .and. (.not. prev_recombined(i)) .and. (etoti < 0.)) then ! Recombination event and particle is still bound j=j+1 @@ -2160,7 +2160,7 @@ subroutine energy_profile(time,npart,particlemass,xyzh,vxyzu) select case (iquantity) case(1) ! Energy call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) quant(i,1) = ekini + epoti + ethi case(2) ! Entropy if ((ieos==10) .and. (ientropy==2)) then @@ -2308,7 +2308,7 @@ subroutine velocity_histogram(time,num,npart,particlemass,xyzh,vxyzu) rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) vr(i) = dot_product(xyzh(1:3,i),vxyzu(1:3,i)) / sqrt(dot_product(xyzh(1:3,i),xyzh(1:3,i))) if (ekini+epoti > 0.) then @@ -2616,7 +2616,7 @@ subroutine unbound_profiles(time,num,npart,particlemass,xyzh,vxyzu) rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,ethi) etoti = ekini + epoti + ethi ! Ekin + Epot + Eth > 0 @@ -2724,7 +2724,7 @@ subroutine unbound_ionfrac(time,npart,particlemass,xyzh,vxyzu) rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,ethi) etoti = ekini + epoti + ethi if ((etoti > 0.) .and. (.not. prev_unbound(i))) then @@ -2794,7 +2794,7 @@ subroutine unbound_temp(time,npart,particlemass,xyzh,vxyzu) rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),eos_vars(itemp,i),vxyzu(4,i)) call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) etoti = ekini + epoti + ethi if ((etoti > 0.) .and. (.not. prev_unbound(i))) then @@ -2864,7 +2864,7 @@ subroutine recombination_stats(time,num,npart,particlemass,xyzh,vxyzu) rhopart = rhoh(xyzh(4,i), particlemass) call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),gamma,ethi) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) etoti = ekini + epoti + ethi call get_eos_pressure_temp_mesa(rhopart*unit_density,vxyzu(4,i)*unit_ergg,pressure,temperature) ! This should depend on ieos From 5b1bf16111fb10ebf16a33e3cb82304938179840 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 3 May 2024 15:50:43 +0200 Subject: [PATCH 40/45] fix issue with optional arg and omp reduction --- src/main/substepping.F90 | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index ca40e3e92..83786af5b 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -480,7 +480,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & ! ! Main integration scheme ! - call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + call kick(dk(1),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass,dptmass) if (use_regnbody) then call evolve_groups(n_group,nptmass,time_par,time_par+ck(1)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) @@ -503,7 +503,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,fsink_old,group_info) - call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass,dptmass) call evolve_groups(n_group,nptmass,time_par,time_par+ck(2)*dt,group_info,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) @@ -514,7 +514,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & else call get_force(nptmass,npart,nsubsteps,ntypes,time_par,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass, & vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dk(2),force_count,extf_vdep_flag,fsink_old) - call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass) + call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,fext,fxyz_ptmass,dsdt_ptmass,dptmass) call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass) @@ -629,7 +629,7 @@ end subroutine drift subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, & fext,fxyz_ptmass,dsdt_ptmass,dptmass,ibin_wake,nbinmax,timei,fxyz_ptmass_sinksink,accreted) - use part, only:isdead_or_accreted,massoftype,iamtype,iamboundary,iphase,ispinx,ispiny,ispinz,igas + use part, only:isdead_or_accreted,massoftype,iamtype,iamboundary,iphase,ispinx,ispiny,ispinz,igas,ndptmass use ptmass, only:f_acc,ptmass_accrete,pt_write_sinkev,update_ptmass,ptmass_kick use externalforces, only:accrete_particles use options, only:iexternalforce @@ -643,7 +643,8 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, real, intent(inout) :: xyzh(:,:) real, intent(inout) :: vxyzu(:,:),fext(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:),fxyz_ptmass(:,:),dsdt_ptmass(:,:) - real, optional, intent(inout) :: dptmass(:,:),fxyz_ptmass_sinksink(:,:) + real, intent(inout) :: dptmass(ndptmass,nptmass) + real, optional, intent(inout) :: fxyz_ptmass_sinksink(:,:) real, optional, intent(in) :: timei integer(kind=1), optional, intent(inout) :: ibin_wake(:) integer(kind=1), optional, intent(in) :: nbinmax @@ -654,7 +655,7 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, integer :: naccreted,nfail,nlive real :: dkdt,pmassi,fxi,fyi,fzi,accretedmass - if (present(dptmass) .and. present(timei) .and. present(ibin_wake) .and. present(nbinmax)) then + if (present(timei) .and. present(ibin_wake) .and. present(nbinmax)) then is_accretion = .true. else is_accretion = .false. @@ -706,7 +707,7 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, nlive = 0 ibin_wakei = 0 dptmass(:,1:nptmass) = 0. - !$omp parallel default(none) & + !$omp parallel do default(none) & !$omp shared(maxp,maxphase) & !$omp shared(npart,xyzh,vxyzu,fext,dkdt,iphase,ntypes,massoftype,timei,nptmass,sts_it_n) & !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,f_acc) & @@ -714,10 +715,11 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, !$omp shared(nbinmax,ibin_wake) & !$omp private(i,accreted,nfaili,fxi,fyi,fzi) & !$omp firstprivate(itype,pmassi,ibin_wakei) & - !$omp reduction(+:dptmass) & !$omp reduction(+:accretedmass) & - !$omp reduction(+:nfail,naccreted,nlive) - !$omp do + !$omp reduction(+:nfail) & + !$omp reduction(+:naccreted) & + !$omp reduction(+:nlive) & + !$omp reduction(+:dptmass) accreteloop: do i=1,npart if (.not.isdead_or_accreted(xyzh(4,i))) then if (ntypes > 1 .and. maxphase==maxp) then @@ -764,8 +766,7 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, nlive = nlive + 1 endif enddo accreteloop - !$omp enddo - !$omp end parallel + !$omp end parallel do if (npart > 2 .and. nlive < 2) then call fatal('step','all particles accreted',var='nlive',ival=nlive) @@ -859,6 +860,8 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, if(present(group_info)) then wsub = .true. + else + wsub = .false. endif From 5a7532ef303e3b47775d8d5b68a076b213128417 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Mon, 6 May 2024 10:52:54 +0200 Subject: [PATCH 41/45] (CE-analysis) remove case 14 for saving particle therm. quantities into file --- src/utils/analysis_common_envelope.f90 | 54 +------------------------- 1 file changed, 2 insertions(+), 52 deletions(-) diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 7edc51774..0a40d006f 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -62,9 +62,6 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) integer :: unitnum,i,ncols logical :: requires_eos_opts - !case 5 variables - real :: rhopart - !case 7 variables character(len=17), allocatable :: columns(:) @@ -76,17 +73,9 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) real, allocatable :: histogram_data(:,:) real :: ang_vel - real :: pres_1i, proint_1i, peint_1i, temp_1i - real :: troint_1i, teint_1i, entrop_1i, abad_1i, gamma1_1i, gam_1i - - !case 16 variables - real, allocatable :: thermodynamic_quantities(:,:) - real, allocatable :: radius_1i, dens_1i - - !chose analysis type if (dump_number==0) then - print "(41(a,/))", & + print "(40(a,/))", & ' 1) Sink separation', & ' 2) Bound and unbound quantities', & ' 3) Energies', & @@ -99,7 +88,6 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) '11) Profile of newly unbound particles', & '12) Sink properties', & '13) MESA EoS compute total entropy and other average td quantities', & - '14) MESA EoS save on file thermodynamical quantities for all particles', & '15) Gravitational drag on sinks', & '16) CoM of gas around primary core', & '17) Miscellaneous', & @@ -136,7 +124,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) xyzmh_ptmass,vxyz_ptmass,omega_corotate,dump_number) ! List of analysis options that require specifying EOS options - requires_eos_opts = any((/2,3,4,5,6,8,9,11,13,14,15,20,21,22,23,24,25,26,29,30,31,32,33,35,41/) == analysis_to_perform) + requires_eos_opts = any((/2,3,4,5,6,8,9,11,13,15,20,21,22,23,24,25,26,29,30,31,32,33,35,41/) == analysis_to_perform) if (dump_number == 0 .and. requires_eos_opts) call set_eos_options(analysis_to_perform) select case(analysis_to_perform) @@ -210,48 +198,10 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) call sink_properties(time,npart,particlemass,xyzh,vxyzu) case(13) !MESA EoS compute total entropy and other average thermodynamical quantities call bound_unbound_thermo(time,npart,particlemass,xyzh,vxyzu) - case(14) !MESA EoS save on file thermodynamical quantities for all particles - allocate(thermodynamic_quantities(5,npart)) - do i=1,npart - - !particle radius - radius_1i = distance(xyzh(1:3,i)) * udist - - !particles density in code units - rhopart = rhoh(xyzh(4,i), particlemass) - dens_1i = rhopart * unit_density - - !gets entropy for the current particle - call get_eos_various_mesa(rhopart*unit_density,vxyzu(4,i) * unit_ergg, & - pres_1i,proint_1i,peint_1i,temp_1i,troint_1i, & - teint_1i,entrop_1i,abad_1i,gamma1_1i,gam_1i) - - !stores everything in an array - thermodynamic_quantities(1,i) = radius_1i - thermodynamic_quantities(2,i) = dens_1i - thermodynamic_quantities(3,i) = pres_1i - thermodynamic_quantities(4,i) = temp_1i - thermodynamic_quantities(5,i) = entrop_1i - - enddo - ncols = 5 - allocate(columns(ncols)) - columns = (/' radius', & - ' density', & - ' pressure', & - ' temperature', & - ' entropy'/) - call write_file('td_quantities', 'thermodynamics', columns, thermodynamic_quantities, npart, ncols, num) - - unitnum = unitnum + 1 - deallocate(thermodynamic_quantities) - case(15) !Gravitational drag on sinks call gravitational_drag(time,npart,particlemass,xyzh,vxyzu) - case(16) call get_core_gas_com(time,npart,xyzh,vxyzu) - case(17) ncols = 6 allocate(columns(ncols)) From 4eb6a35ee11e340bae9ae6b6d10ac0b116d4502f Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Mon, 6 May 2024 10:58:40 +0200 Subject: [PATCH 42/45] (CE-analysis) remove redundant case 17, replaced by divv functionality --- src/utils/analysis_common_envelope.f90 | 54 -------------------------- 1 file changed, 54 deletions(-) diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 0a40d006f..376048ce8 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -62,17 +62,6 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) integer :: unitnum,i,ncols logical :: requires_eos_opts - !case 7 variables - character(len=17), allocatable :: columns(:) - - !case 12 variables - real :: etoti, ekini, einti, epoti, phii - - real, dimension(3) :: com_xyz, com_vxyz - real, dimension(3) :: xyz_a, vxyz_a - real, allocatable :: histogram_data(:,:) - real :: ang_vel - !chose analysis type if (dump_number==0) then print "(40(a,/))", & @@ -90,7 +79,6 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) '13) MESA EoS compute total entropy and other average td quantities', & '15) Gravitational drag on sinks', & '16) CoM of gas around primary core', & - '17) Miscellaneous', & '18) J-E plane', & '19) Rotation profile', & '20) Energy profile', & @@ -202,48 +190,6 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) call gravitational_drag(time,npart,particlemass,xyzh,vxyzu) case(16) call get_core_gas_com(time,npart,xyzh,vxyzu) - case(17) - ncols = 6 - allocate(columns(ncols)) - columns = (/' x', & - ' y', & - ' z', & - ' r', & - 'spec. energy', & - ' omega ratio'/) - - call orbit_com(npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass,com_xyz,com_vxyz) - - ang_vel = 0. - - do i=1,nptmass - if (xyzmh_ptmass(4,i) > 0.) then - xyz_a(1:3) = xyzmh_ptmass(1:3,i) - com_xyz(1:3) - vxyz_a(1:3) = vxyz_ptmass(1:3,i) - com_vxyz(1:3) - ang_vel = ang_vel + (-xyz_a(2) * vxyz_a(1) + xyz_a(1) * vxyz_a(2)) / dot_product(xyz_a(1:2), xyz_a(1:2)) - endif - enddo - - ang_vel = ang_vel / 2. - - allocate(histogram_data(6,npart)) - - do i=1,npart - xyz_a(1:3) = xyzh(1:3,i) - com_xyz(1:3) - vxyz_a(1:3) = vxyzu(1:3,i) - com_vxyz(1:3) - - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) - histogram_data(1:3,i) = xyzh(1:3,i) - histogram_data(4,i) = distance(xyz_a(1:3)) - histogram_data(5,i) = epoti + ekini - histogram_data(6,i) = (-xyz_a(2) * vxyz_a(1) + xyz_a(1) * vxyz_a(2)) / dot_product(xyz_a(1:2), xyz_a(1:2)) - histogram_data(6,i) = (histogram_data(6,i) - ang_vel) / ang_vel - enddo - - call write_file('specific_energy_particles', 'histogram', columns, histogram_data, size(histogram_data(1,:)), ncols, num) - - deallocate(histogram_data) - case(18) call J_E_plane(num,npart,particlemass,xyzh,vxyzu) end select From 27c5e3508f6fd5c902cbfbd413991cc0f87d19c8 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Mon, 6 May 2024 11:06:51 +0200 Subject: [PATCH 43/45] (CE-analysis) clean up case numbers --- src/utils/analysis_common_envelope.f90 | 131 ++++++++++++------------- 1 file changed, 65 insertions(+), 66 deletions(-) diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 376048ce8..a7ec86cff 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -59,7 +59,6 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) integer, intent(in) :: num,npart,iunit real, intent(inout) :: xyzh(:,:),vxyzu(:,:) real, intent(in) :: particlemass,time - integer :: unitnum,i,ncols logical :: requires_eos_opts !chose analysis type @@ -74,37 +73,37 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ' 7) Simulation units and particle properties', & ' 8) Output .divv', & ' 9) EoS testing', & - '11) Profile of newly unbound particles', & - '12) Sink properties', & - '13) MESA EoS compute total entropy and other average td quantities', & - '15) Gravitational drag on sinks', & - '16) CoM of gas around primary core', & - '18) J-E plane', & - '19) Rotation profile', & - '20) Energy profile', & - '21) Recombination statistics', & - '22) Optical depth profile', & - '23) Particle tracker', & - '24) Unbound ion fraction', & - '25) Optical depth at recombination', & - '26) Envelope binding energy', & - '27) Print dumps number matching separation', & - '28) Companion mass coordinate vs. time', & - '29) Energy histogram',& - '30) Analyse disk',& - '31) Recombination energy vs time',& - '32) Binding energy profile',& - '33) planet_rvm',& - '34) Velocity histogram',& - '35) Unbound temperature',& - '36) Planet mass distribution',& - '37) Planet profile',& - '38) Velocity profile',& - '39) Angular momentum profile',& - '40) Keplerian velocity profile',& - '41) Total dust mass' + '10) Profile of newly unbound particles', & + '11) Sink properties', & + '12) MESA EoS compute total entropy and other average td quantities', & + '13) Gravitational drag on sinks', & + '14) CoM of gas around primary core', & + '15) J-E plane', & + '16) Rotation profile', & + '17) Energy profile', & + '18) Recombination statistics', & + '19) Optical depth profile', & + '20) Particle tracker', & + '21) Unbound ion fraction', & + '22) Optical depth at recombination', & + '23) Envelope binding energy', & + '24) Print dumps number matching separation', & + '25) Companion mass coordinate vs. time', & + '26) Energy histogram',& + '27) Analyse disk',& + '28) Recombination energy vs time',& + '29) Binding energy profile',& + '30) planet_rvm',& + '31) Velocity histogram',& + '32) Unbound temperature',& + '33) Planet mass distribution',& + '34) Planet profile',& + '35) Velocity profile',& + '36) Angular momentum profile',& + '37) Keplerian velocity profile',& + '38) Total dust mass' analysis_to_perform = 1 - call prompt('Choose analysis type ',analysis_to_perform,1,41) + call prompt('Choose analysis type ',analysis_to_perform,1,38) endif call reset_centreofmass(npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass) @@ -112,7 +111,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) xyzmh_ptmass,vxyz_ptmass,omega_corotate,dump_number) ! List of analysis options that require specifying EOS options - requires_eos_opts = any((/2,3,4,5,6,8,9,11,13,15,20,21,22,23,24,25,26,29,30,31,32,33,35,41/) == analysis_to_perform) + requires_eos_opts = any((/2,3,4,5,6,8,9,10,13,17,18,19,20,21,22,23,26,27,28,29,30,32,38/) == analysis_to_perform) if (dump_number == 0 .and. requires_eos_opts) call set_eos_options(analysis_to_perform) select case(analysis_to_perform) @@ -134,64 +133,64 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) call output_divv_files(time,dumpfile,npart,particlemass,xyzh,vxyzu) case(9) !EoS testing call eos_surfaces - case(11) !New unbound particle profiles in time + case(10) !New unbound particle profiles in time call unbound_profiles(time,num,npart,particlemass,xyzh,vxyzu) - case(19) ! Rotation profile + case(11) !sink properties + call sink_properties(time,npart,particlemass,xyzh,vxyzu) + case(12) !MESA EoS compute total entropy and other average thermodynamical quantities + call bound_unbound_thermo(time,npart,particlemass,xyzh,vxyzu) + case(13) !Gravitational drag on sinks + call gravitational_drag(time,npart,particlemass,xyzh,vxyzu) + case(14) + call get_core_gas_com(time,npart,xyzh,vxyzu) + case(15) + call J_E_plane(num,npart,particlemass,xyzh,vxyzu) + case(16) ! Rotation profile call rotation_profile(time,num,npart,xyzh,vxyzu) - case(20) ! Energy profile + case(17) ! Energy profile call energy_profile(time,npart,particlemass,xyzh,vxyzu) - case(21) ! Recombination statistics + case(18) ! Recombination statistics call recombination_stats(time,num,npart,particlemass,xyzh,vxyzu) - case(22) ! Optical depth profile + case(19) ! Optical depth profile call tau_profile(time,num,npart,particlemass,xyzh) - case(23) ! Particle tracker + case(20) ! Particle tracker call track_particle(time,particlemass,xyzh,vxyzu) - case(24) ! Unbound ion fractions + case(21) ! Unbound ion fractions call unbound_ionfrac(time,npart,particlemass,xyzh,vxyzu) - case(25) ! Optical depth at recombination + case(22) ! Optical depth at recombination call recombination_tau(time,npart,particlemass,xyzh,vxyzu) - case(26) ! Calculate binding energy outside core + case(23) ! Calculate binding energy outside core call env_binding_ene(npart,particlemass,xyzh,vxyzu) - case(27) ! Print dump number corresponding to given set of sink-sink separations + case(24) ! Print dump number corresponding to given set of sink-sink separations call print_dump_numbers(dumpfile) - case(28) ! Companion mass coordinate (spherical mass shells) vs. time + case(25) ! Companion mass coordinate (spherical mass shells) vs. time call m_vs_t(time,npart,particlemass,xyzh) - case(29) ! Energy histogram + case(26) ! Energy histogram call energy_hist(time,npart,particlemass,xyzh,vxyzu) - case(30) ! Analyse disk around companion + case(27) ! Analyse disk around companion call analyse_disk(num,npart,particlemass,xyzh,vxyzu) - case(31) ! Recombination energy vs. time + case(28) ! Recombination energy vs. time call erec_vs_t(time,npart,particlemass,xyzh) - case(32) ! Binding energy profile + case(29) ! Binding energy profile call create_bindingEnergy_profile(time,num,npart,particlemass,xyzh,vxyzu) - case(33) ! Planet coordinates and mass + case(30) ! Planet coordinates and mass call planet_rvm(time,particlemass,xyzh,vxyzu) - case(34) ! Velocity histogram + case(31) ! Velocity histogram call velocity_histogram(time,num,npart,particlemass,xyzh,vxyzu) - case(35) ! Unbound temperatures + case(32) ! Unbound temperatures call unbound_temp(time,npart,particlemass,xyzh,vxyzu) - case(36) ! Planet mass distribution + case(33) ! Planet mass distribution call planet_mass_distribution(time,num,npart,xyzh) - case(37) ! Calculate planet profile + case(34) ! Calculate planet profile call planet_profile(num,dumpfile,particlemass,xyzh,vxyzu) - case(38) ! Velocity profile + case(35) ! Velocity profile call velocity_profile(time,num,npart,particlemass,xyzh,vxyzu) - case(39) ! Angular momentum profile + case(36) ! Angular momentum profile call angular_momentum_profile(time,num,npart,particlemass,xyzh,vxyzu) - case(40) ! Keplerian velocity profile + case(37) ! Keplerian velocity profile call vkep_profile(time,num,npart,particlemass,xyzh,vxyzu) - case(41) !Total dust mass + case(38) !Total dust mass call total_dust_mass(time,npart,particlemass,xyzh) - case(12) !sink properties - call sink_properties(time,npart,particlemass,xyzh,vxyzu) - case(13) !MESA EoS compute total entropy and other average thermodynamical quantities - call bound_unbound_thermo(time,npart,particlemass,xyzh,vxyzu) - case(15) !Gravitational drag on sinks - call gravitational_drag(time,npart,particlemass,xyzh,vxyzu) - case(16) - call get_core_gas_com(time,npart,xyzh,vxyzu) - case(18) - call J_E_plane(num,npart,particlemass,xyzh,vxyzu) end select !increase dump number counter dump_number = dump_number + 1 From 6835bd154d782a8f94a52a8acec8a291d610a0c0 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Thu, 9 May 2024 16:11:37 +0200 Subject: [PATCH 44/45] fix accreted flag uninitialized --- src/main/substepping.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index e0f2f35b8..aa7380beb 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -467,6 +467,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & nsubsteps = 0 dtextforce_min = huge(dt) done = .false. + accreted = .false. substeps: do while (timei <= t_end_step .and. .not.done) force_count = 0 From dabe2a2a26972cb7cc8bcb858131dca02b0f7f8c Mon Sep 17 00:00:00 2001 From: Yrisch Date: Fri, 10 May 2024 19:33:52 +0200 Subject: [PATCH 45/45] remove runtime option and set use_regnbody in the setup file --- src/main/ptmass.F90 | 3 --- src/setup/setup_starcluster.f90 | 14 +++++++++----- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 111055354..016c77d8d 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1947,7 +1947,6 @@ subroutine write_options_ptmass(iunit) call write_inopt(f_acc,'f_acc','particles < f_acc*h_acc accreted without checks',iunit) call write_inopt(r_merge_uncond,'r_merge_uncond','sinks will unconditionally merge within this separation',iunit) call write_inopt(r_merge_cond,'r_merge_cond','sinks will merge if bound within this radius',iunit) - call write_inopt(use_regnbody, 'use_regnbody', 'Subsystem (SD and secular and AR) integration method', iunit) end subroutine write_options_ptmass @@ -2022,8 +2021,6 @@ subroutine read_options_ptmass(name,valstring,imatch,igotall,ierr) read(valstring,*,iostat=ierr) r_merge_cond if (r_merge_cond > 0. .and. r_merge_cond < r_merge_uncond) call fatal(label,'0 < r_merge_cond < r_merge_uncond') ngot = ngot + 1 - case('use_regnbody') - read(valstring,*,iostat=ierr) use_regnbody case default imatch = .false. end select diff --git a/src/setup/setup_starcluster.f90 b/src/setup/setup_starcluster.f90 index 52af1c30f..429558843 100644 --- a/src/setup/setup_starcluster.f90 +++ b/src/setup/setup_starcluster.f90 @@ -46,10 +46,10 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use physcon, only:solarm,kpc,pi,au,years,pc use io, only:fatal,iprint,master use eos, only:gmw - use timestep, only:dtmax + use timestep, only:dtmax,tmax use spherical, only:set_sphere use datafiles, only:find_phantom_datafile - use ptmass, only:use_fourthorder + use ptmass, only:use_fourthorder,use_regnbody integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) @@ -61,6 +61,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, real, intent(out) :: vxyzu(:,:) character(len=len(fileprefix)+6) :: setupfile character(len=len(datafile)) :: filename + integer :: ntot integer :: ierr,i real :: xcom(3),vcom(3),mtot real :: psep @@ -78,9 +79,12 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, polyk = 0. gamma = 5./3. gmw = 0.6 ! completely ionized, solar abu; eventually needs to be WR abu - dtmax = 0.01 + dtmax = 1.e-5 + tmax = 0.001 use_fourthorder = .true. - m_gas = 1.e-20 + use_regnbody = .false. + m_gas = 1.e-4 + ntot = 2**21 ! ! read setup parameters from the .setup file ! if file does not exist, then ask for user input @@ -132,7 +136,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! setup initial sphere of particles to prevent initialisation problems ! psep = 1.0 - call set_sphere('cubic',id,master,0.,10.,psep,hfact,npart,xyzh) + call set_sphere('random',id,master,0.,10.,psep,hfact,npart,xyzh,np_requested=ntot) vxyzu(4,:) = 5.317e-4 npartoftype(igas) = npart