From 848ccfff3026d77155d3d9c3d6c7e7f8395f8e84 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Fri, 29 Sep 2023 16:58:47 +0100 Subject: [PATCH 001/134] fix merge conflicts --- src/main/cooling_stamatellos.f90 | 8 ++++++++ src/main/force.F90 | 2 +- src/main/step_leapfrog.F90 | 1 + 3 files changed, 10 insertions(+), 1 deletion(-) diff --git a/src/main/cooling_stamatellos.f90 b/src/main/cooling_stamatellos.f90 index 282c50beb..e1ea435cc 100644 --- a/src/main/cooling_stamatellos.f90 +++ b/src/main/cooling_stamatellos.f90 @@ -87,6 +87,14 @@ subroutine cooling_S07(rhoi,ui,dudti_cool,xi,yi,zi,Tfloor,dudti_sph,dt,i) Ti,gmwi) presi = eos_vars(igasP,i) + +if (isnan(kappaBari)) then + print *, "kappaBari is NaN\n", " ui(erg) = ", ui*unit_ergg, "rhoi=", rhoi*unit_density, "Ti=", Ti, & + "i=", i + stop +endif + + select case (od_method) case (1) coldensi = sqrt(abs(poti*rhoi)/4.d0/pi) ! G cancels out as G=1 in code diff --git a/src/main/force.F90 b/src/main/force.F90 index 1ad98cd5a..a3257e649 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -1366,7 +1366,7 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g projv = dvx*runix + dvy*runiy + dvz*runiz if (iamgasj .and. maxvxyzu >= 4) then - enj = utherm(vxyzu(:,j),rhoj,gamma) + enj = vxyzu(4,j) if (eos_is_non_ideal(ieos)) then ! Is this condition required, or should this be always true? tempj = eos_vars(itemp,j) denij = 0.5*(eni/tempi + enj/tempj)*(tempi - tempj) ! dU = c_V * dT diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index e38de93f6..8679970a7 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -550,6 +550,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) endif endif endif + endif enddo corrector !$omp enddo !$omp end parallel From e933a36cddf8bd07bdb217064db914e7303524dc Mon Sep 17 00:00:00 2001 From: Alison Young Date: Thu, 30 Nov 2023 14:13:28 +0000 Subject: [PATCH 002/134] Added combined Stamatellos/Lombardi cooling method --- src/main/cooling_stamatellos.f90 | 92 ++++++++++++++------------------ 1 file changed, 41 insertions(+), 51 deletions(-) diff --git a/src/main/cooling_stamatellos.f90 b/src/main/cooling_stamatellos.f90 index e1ea435cc..5a32f774b 100644 --- a/src/main/cooling_stamatellos.f90 +++ b/src/main/cooling_stamatellos.f90 @@ -57,16 +57,16 @@ end subroutine init_star ! subroutine cooling_S07(rhoi,ui,dudti_cool,xi,yi,zi,Tfloor,dudti_sph,dt,i) use io, only:warning - use physcon, only:steboltz,pi,solarl,Rg - use units, only:umass,udist,unit_density,unit_ergg,utime + use physcon, only:steboltz,pi,solarl,Rg,kb_on_mh + use units, only:umass,udist,unit_density,unit_ergg,utime,unit_pressure use eos_stamatellos, only:getopac_opdep,getintenerg_opdep,gradP_cool,Gpot_cool use part, only:eos_vars,igasP,xyzmh_ptmass,igamma real,intent(in) :: rhoi,ui,dudti_sph,xi,yi,zi,Tfloor,dt integer,intent(in) :: i real,intent(out) :: dudti_cool real :: coldensi,kappaBari,kappaParti,ri2 - real :: gmwi,Tmini4,Ti,dudt_rad,Teqi - real :: tcool,ueqi,umini,tthermi,poti,presi + real :: gmwi,Tmini4,Ti,dudt_rad,Teqi,Hstam,HLom + real :: tcool,ueqi,tthermi,poti,presi,Hcomb poti = Gpot_cool(i) ! Tfloor is from input parameters and is background heating @@ -85,8 +85,8 @@ subroutine cooling_S07(rhoi,ui,dudti_cool,xi,yi,zi,Tfloor,dudti_sph,dt,i) ! get opacities & Ti for ui call getopac_opdep(ui*unit_ergg,rhoi*unit_density,kappaBari,kappaParti,& Ti,gmwi) - presi = eos_vars(igasP,i) - + presi = kb_on_mh*rhoi*unit_density*Ti/gmwi + presi = presi/unit_pressure if (isnan(kappaBari)) then print *, "kappaBari is NaN\n", " ui(erg) = ", ui*unit_ergg, "rhoi=", rhoi*unit_density, "Ti=", Ti, & @@ -94,68 +94,58 @@ subroutine cooling_S07(rhoi,ui,dudti_cool,xi,yi,zi,Tfloor,dudti_sph,dt,i) stop endif - select case (od_method) case (1) +! Stamatellos+ 2007 method coldensi = sqrt(abs(poti*rhoi)/4.d0/pi) ! G cancels out as G=1 in code coldensi = 0.368d0*coldensi ! n=2 in polytrope formalism Forgan+ 2009 coldensi = coldensi*umass/udist/udist ! physical units case (2) -! Lombardi+ method of estimating the mean column density - coldensi = 1.014d0 * presi / abs(gradP_cool(i))! 1.014d0 * P/(-gradP/rho) Lombardi+ 2015 +! Lombardi+ 2015 method of estimating the mean column density + coldensi = 1.014d0 * presi / abs(gradP_cool(i))! 1.014d0 * P/(-gradP/rho) coldensi = coldensi *umass/udist/udist ! physical units + case (3) + HStam = sqrt(abs(poti*rhoi)/4.0d0/pi)*0.368d0/rhoi + HLom = 1.014d0*presi/abs(gradP_cool(i))/rhoi + Hcomb = 1.0/sqrt((1.0d0/HLom)**2.0d0 + (1.0d0/HStam)**2.0d0) + coldensi = Hcomb*rhoi + coldensi = coldensi*umass/udist/udist end select tcool = (coldensi**2d0)*kappaBari + (1.d0/kappaParti) ! physical units dudt_rad = 4.d0*steboltz*(Tmini4 - Ti**4.d0)/tcool/unit_ergg*utime! code units - ! calculate Teqi - if (od_method == 1) then - Teqi = dudti_sph*(coldensi**2.d0*kappaBari + (1.d0/kappaParti))*unit_ergg/utime - Teqi = Teqi/4.d0/steboltz - Teqi = Teqi + Tmini4 - if (Teqi < Tmini4) then - Teqi = Tmini4**(1.0/4.0) - else - Teqi = Teqi**(1.0/4.0) - endif - call getintenerg_opdep(Teqi,rhoi*unit_density,ueqi) - ueqi = ueqi/unit_ergg + Teqi = dudti_sph*(coldensi**2.d0*kappaBari + (1.d0/kappaParti))*unit_ergg/utime + Teqi = Teqi/4.d0/steboltz + Teqi = Teqi + Tmini4 + if (Teqi < Tmini4) then + Teqi = Tmini4**(1.0/4.0) + else + Teqi = Teqi**(1.0/4.0) endif - - call getintenerg_opdep(Tmini4**(1.0/4.0),rhoi*unit_density,umini) - umini = umini/unit_ergg + call getintenerg_opdep(Teqi,rhoi*unit_density,ueqi) + ueqi = ueqi/unit_ergg ! calculate thermalization timescale and -! internal energy update -> put in form where it'll work as dudtcool - select case (od_method) - case (1) - if ((dudti_sph + dudt_rad) == 0.d0) then - tthermi = 0d0 - else - tthermi = abs((ueqi - ui)/(dudti_sph + dudt_rad)) - endif - if (tthermi == 0d0) then - dudti_cool = 0.d0 ! condition if denominator above is zero - else - dudti_cool = (ui*exp(-dt/tthermi) + ueqi*(1.d0-exp(-dt/tthermi)) -ui)/dt !code units - endif - case (2) - if (abs(dudt_rad) > 0.d0) then - tthermi = (umini - ui) / (dudt_rad)! + tiny(dudt_rad)) - dudti_cool = (ui*exp(-dt/tthermi) + umini*(1.d0-exp(-dt/tthermi)) -ui)/dt + dudti_sph - else ! ie Tmini == Ti - dudti_cool = (umini - ui)/dt + dudti_sph ! ? CHECK THIS - endif - end select - +! internal energy update -> this is in a form where it'll work as dudtcool + if ((dudti_sph + dudt_rad) == 0.d0) then + tthermi = 0d0 + else + tthermi = abs((ueqi - ui)/(dudti_sph + dudt_rad)) + endif + if (tthermi == 0d0) then + dudti_cool = 0.d0 ! condition if denominator above is zero + else + dudti_cool = (ui*exp(-dt/tthermi) + ueqi*(1.d0-exp(-dt/tthermi)) -ui)/dt !code units + endif + if (isnan(dudti_cool)) then print *, "kappaBari=",kappaBari, "kappaParti=",kappaParti print *, "rhoi=",rhoi, "Ti=", Ti print *, "tcool=",tcool,"coldensi=",coldensi,"dudti_sph",dudti_sph - print *, "dt=",dt,"tthermi=", tthermi,"umini=", umini + print *, "dt=",dt,"tthermi=", tthermi print *, "dudt_rad=", dudt_rad call warning("In Stamatellos cooling","dudticool=NaN. ui",val=ui) stop @@ -174,7 +164,7 @@ subroutine write_options_cooling_stamatellos(iunit) !N.B. Tfloor handled in cooling.F90 call write_inopt(eos_file,'EOS_file','File containing tabulated EOS values',iunit) - call write_inopt(od_method,'OD method','Method for estimating optical depth: (1) potential (2) pressure',iunit) + call write_inopt(od_method,'OD method','Method for estimating optical depth: (1) potential (2) pressure (3) combined',iunit) call write_inopt(Lstar,'Lstar','Luminosity of host star for calculating Tmin (Lsun)',iunit) end subroutine write_options_cooling_stamatellos @@ -196,8 +186,8 @@ subroutine read_options_cooling_stamatellos(name,valstring,imatch,igotallstam,ie ngot = ngot + 1 case('OD method') read(valstring,*,iostat=ierr) od_method - if (od_method < 1 .or. od_method > 2) then - call fatal('cooling options','od_method must be 1 or 2',var='od_method',ival=od_method) + if (od_method < 1 .or. od_method > 3) then + call fatal('cooling options','od_method must be 1, 2 or 3',var='od_method',ival=od_method) endif ngot = ngot + 1 case('EOS_file') @@ -206,7 +196,7 @@ subroutine read_options_cooling_stamatellos(name,valstring,imatch,igotallstam,ie case default imatch = .false. end select - if (od_method /= 1 .and. od_method /= 2) then + if (od_method /= 1 .and. od_method /= 2 .and. od_method /= 3) then call warning('cooling_stamatellos','optical depth method unknown') endif From f746def2a443982ea13776cc412b102c040a976e Mon Sep 17 00:00:00 2001 From: Alison Young Date: Thu, 30 Nov 2023 14:26:50 +0000 Subject: [PATCH 003/134] Bug fix in cooling_stamatellos.f90 --- src/main/cooling_stamatellos.f90 | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/main/cooling_stamatellos.f90 b/src/main/cooling_stamatellos.f90 index 5a32f774b..a5550f598 100644 --- a/src/main/cooling_stamatellos.f90 +++ b/src/main/cooling_stamatellos.f90 @@ -66,7 +66,7 @@ subroutine cooling_S07(rhoi,ui,dudti_cool,xi,yi,zi,Tfloor,dudti_sph,dt,i) real,intent(out) :: dudti_cool real :: coldensi,kappaBari,kappaParti,ri2 real :: gmwi,Tmini4,Ti,dudt_rad,Teqi,Hstam,HLom - real :: tcool,ueqi,tthermi,poti,presi,Hcomb + real :: tcool,ueqi,umini,tthermi,poti,presi,Hcomb poti = Gpot_cool(i) ! Tfloor is from input parameters and is background heating @@ -127,6 +127,9 @@ subroutine cooling_S07(rhoi,ui,dudti_cool,xi,yi,zi,Tfloor,dudti_sph,dt,i) call getintenerg_opdep(Teqi,rhoi*unit_density,ueqi) ueqi = ueqi/unit_ergg + call getintenerg_opdep(Tmini4**(1.0/4.0),rhoi*unit_density,umini) + umini = umini/unit_ergg + ! calculate thermalization timescale and ! internal energy update -> this is in a form where it'll work as dudtcool if ((dudti_sph + dudt_rad) == 0.d0) then From d8045dbe604f470059c5e2a6096af452dad259d9 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Wed, 10 Jan 2024 16:29:23 +0000 Subject: [PATCH 004/134] adding Stamatellos/Lombardi opacity --- src/main/radiation_utils.f90 | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/src/main/radiation_utils.f90 b/src/main/radiation_utils.f90 index 1465081a5..100c387d8 100644 --- a/src/main/radiation_utils.f90 +++ b/src/main/radiation_utils.f90 @@ -411,13 +411,15 @@ end function get_kappa ! calculate opacities !+ !-------------------------------------------------------------------- -subroutine get_opacity(opacity_type,density,temperature,kappa) +subroutine get_opacity(opacity_type,density,temperature,kappa,u) + use eos_stamatellos, only:getopac_opdep use mesa_microphysics, only:get_kappa_mesa - use units, only:unit_density,unit_opacity + use units, only:unit_density,unit_opacity,unit_ergg real, intent(in) :: density, temperature real, intent(out) :: kappa integer, intent(in) :: opacity_type - real :: kapt,kapr,rho_cgs + real, intent(in), optional :: u + real :: kapt,kapr,rho_cgs,Ti,gmwi,gammai,kapBar,kappaPart select case(opacity_type) case(1) @@ -433,6 +435,12 @@ subroutine get_opacity(opacity_type,density,temperature,kappa) ! constant opacity ! kappa = kappa_cgs/unit_opacity + case(3) + ! + ! opacity for Stamatellos/Lombardi EOS + ! + call getopac_opdep(u*unit_ergg,density*unit_density,kapBar,kappaPart,Ti,gmwi) + kappa = kappaPart/unit_opacity case default ! From a5c16dcb714ca03df47254c051c76456a4740837 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Thu, 11 Jan 2024 11:36:39 +0000 Subject: [PATCH 005/134] fixes after merge --- src/main/cons2prim.f90 | 6 +----- src/main/cooling.F90 | 4 +--- src/main/force.F90 | 4 +--- 3 files changed, 3 insertions(+), 11 deletions(-) diff --git a/src/main/cons2prim.f90 b/src/main/cons2prim.f90 index 6a8f87caf..128aa6d18 100644 --- a/src/main/cons2prim.f90 +++ b/src/main/cons2prim.f90 @@ -293,11 +293,7 @@ subroutine cons2prim_everything(npart,xyzh,vxyzu,dvdx,rad,eos_vars,radprop,& ! ! Get the opacity from the density and temperature if required ! - if (iopacity_type == 3) then - call get_opacity(iopacity_type,rhogas,temperaturei,radprop(ikappa,i),u=vxyzu(4,i)) - elseif (iopacity_type > 0) then - call get_opacity(iopacity_type,rhogas,temperaturei,radprop(ikappa,i)) - endif + if (iopacity_type > 0) call get_opacity(iopacity_type,rhogas,temperaturei,radprop(ikappa,i)) endif ! ! Get radiation pressure from the radiation energy, i.e. P = 1/3 E if optically thick diff --git a/src/main/cooling.F90 b/src/main/cooling.F90 index 7fe5f8542..8684182cb 100644 --- a/src/main/cooling.F90 +++ b/src/main/cooling.F90 @@ -95,9 +95,7 @@ subroutine init_cooling(id,master,iprint,ierr) if (.not. ex ) call fatal('cooling','file not found',var=eos_file) if (ieos == 2) call read_optab(eos_file,ierr) if (ierr > 0) call fatal('cooling','Failed to read EOS file',var='ierr',ival=ierr) - if (do_radiation) then - call fatal('cooling','Do radiation was switched on!') - endif + if (do_radiation) then call fatal('cooling','Do radiation was switched on!') call init_star() case(6) call init_cooling_KI02(ierr) diff --git a/src/main/force.F90 b/src/main/force.F90 index 34b528379..0591bb11c 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -1769,12 +1769,10 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g endif duFLD(i) = duFLD(i) + diffterm if (isnan(duFLD(i))) then - print *, "FLD is nan for particle i=, j = ", i,j print *, "rhoi,rhoj,rij2,diffterm",rhoi,rhoj,rij2,diffterm print *, "kfldi, kfldj, Ti,Tj", kfldi,kfldj, Ti,Tj - stop + call fatal('force','duFLD is nan',i,var='duFLD',val=duFLD(i)) endif - ! call calc_FLD(duFLD(i),i,j,q2j,qj,hi121,hi1,pmassj,eos_vars(itemp,j),eos_vars(itemp,j),rhoj) endif endif endif From 28bc64f8d8674545adc41665bccad366a2405dd5 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Thu, 11 Jan 2024 11:40:41 +0000 Subject: [PATCH 006/134] bug fix --- src/main/cooling.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/cooling.F90 b/src/main/cooling.F90 index 8684182cb..c9ffd8a27 100644 --- a/src/main/cooling.F90 +++ b/src/main/cooling.F90 @@ -95,7 +95,7 @@ subroutine init_cooling(id,master,iprint,ierr) if (.not. ex ) call fatal('cooling','file not found',var=eos_file) if (ieos == 2) call read_optab(eos_file,ierr) if (ierr > 0) call fatal('cooling','Failed to read EOS file',var='ierr',ival=ierr) - if (do_radiation) then call fatal('cooling','Do radiation was switched on!') + if (do_radiation) call fatal('cooling','Do radiation was switched on!') call init_star() case(6) call init_cooling_KI02(ierr) From 856101516845b5e2654970266fddf9bead837a2c Mon Sep 17 00:00:00 2001 From: Alison Young Date: Fri, 12 Jan 2024 14:41:59 +0000 Subject: [PATCH 007/134] bug fix --- src/main/force.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/main/force.F90 b/src/main/force.F90 index 0591bb11c..d5284b8b9 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -932,6 +932,7 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g #endif use utils_gr, only:get_bigv use radiation_utils, only:get_rad_R + use io, only:fatal integer, intent(in) :: i logical, intent(in) :: iamgasi,iamdusti real, intent(in) :: xpartveci(:) @@ -1771,7 +1772,7 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g if (isnan(duFLD(i))) then print *, "rhoi,rhoj,rij2,diffterm",rhoi,rhoj,rij2,diffterm print *, "kfldi, kfldj, Ti,Tj", kfldi,kfldj, Ti,Tj - call fatal('force','duFLD is nan',i,var='duFLD',val=duFLD(i)) + call fatal('force','duFLD is nan',i=i,var='duFLD',val=duFLD(i)) endif endif endif From f72bbbf14ddff68551e78ff8095d5378df8bf52f Mon Sep 17 00:00:00 2001 From: Alison Young Date: Fri, 12 Jan 2024 15:29:38 +0000 Subject: [PATCH 008/134] Tidying after merge --- build/Makefile | 3 - src/main/force.F90 | 4 +- src/main/radiation_implicit.f90 | 125 +-------------------------- src/main/radiation_utils.f90 | 2 +- src/main/readwrite_dumps_fortran.F90 | 10 +-- src/main/step_leapfrog.F90 | 2 +- 6 files changed, 9 insertions(+), 137 deletions(-) diff --git a/build/Makefile b/build/Makefile index 2191eeff7..ecc33ca33 100644 --- a/build/Makefile +++ b/build/Makefile @@ -514,9 +514,6 @@ SRCMESA= eos_mesa_microphysics.f90 eos_mesa.f90 SRCEOS = eos_barotropic.f90 eos_stratified.f90 eos_piecewise.f90 ${SRCMESA} eos_shen.f90 eos_helmholtz.f90 eos_idealplusrad.f90 ionization.F90 eos_gasradrec.f90 eos_stamatellos.f90 eos.F90 -SRCEOS = eos_barotropic.f90 eos_stratified.f90 eos_piecewise.f90 ${SRCMESA} eos_shen.f90 eos_helmholtz.f90 eos_idealplusrad.f90 ionization.F90 eos_gasradrec.f90 eos_stamatellos.f90 eos.f90 - - ifeq ($(HDF5), yes) SRCREADWRITE_DUMPS= utils_hdf5.f90 utils_dumpfiles_hdf5.f90 readwrite_dumps_common.F90 readwrite_dumps_fortran.F90 readwrite_dumps_hdf5.F90 readwrite_dumps.F90 else diff --git a/src/main/force.F90 b/src/main/force.F90 index d5284b8b9..dd73c722d 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -1212,7 +1212,6 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g gradpz = 0d0 diffterm = 0d0 if (dt > 0d0) then - ! print *, "rhoi,eni,i,kfldi,Ti", rhoi,eni,i call get_k_fld(rhoi,eni,i,kfldi,Ti) endif endif @@ -1756,7 +1755,6 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g if (icooling == 8) then Gpot_cool(i) = Gpot_cool(i) + pmassj*phii if (doFLD .and. dt > 0.) then - !print *, rhoj, "calling k_fld for j", j, enj call get_k_fld(rhoj,enj,j,kfldj,Tj) if ((kfldj + kfldi) == 0.) then diffterm = 0d0 @@ -1772,7 +1770,7 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g if (isnan(duFLD(i))) then print *, "rhoi,rhoj,rij2,diffterm",rhoi,rhoj,rij2,diffterm print *, "kfldi, kfldj, Ti,Tj", kfldi,kfldj, Ti,Tj - call fatal('force','duFLD is nan',i=i,var='duFLD',val=duFLD(i)) + call fatal('force','duFLD is nan',i=i,var='duFLD',val=duFLD(i)) endif endif endif diff --git a/src/main/radiation_implicit.f90 b/src/main/radiation_implicit.f90 index 51dd0415b..3cabc2937 100644 --- a/src/main/radiation_implicit.f90 +++ b/src/main/radiation_implicit.f90 @@ -46,7 +46,7 @@ module radiation_implicit character(len=*), parameter :: label = 'radiation_implicit' private - public :: do_radiation_implicit,ierr_failed_to_converge,calc_lambda_hybrid + public :: do_radiation_implicit,ierr_failed_to_converge contains @@ -1511,128 +1511,5 @@ subroutine solve_quartic(u1term,u0term,uold,soln,moresweep,ierr) call quarticsolve(a,uold,soln,moresweep,ierr) end subroutine solve_quartic - -!--------------------------------------------------------- -!+ -! Calculate the radiation energy density and flux from -! temperature for hybrid cooling -!+ -!--------------------------------------------------------- - subroutine calc_lambda_hybrid(xyzh,utherm,rho) - use io, only:fatal - use eos_stamatellos, only:getopac_opdep,lambda_fld - use kernel, only:get_kernel,cnormk,radkern - use units, only:unit_density,unit_ergg,unit_opacity,udist - use part, only:massoftype,igas,gradh,hfact - use physcon, only:pi - - real, intent(in) :: xyzh(:,:),utherm(:),rho(:) - integer,allocatable :: ivar(:,:),ijvar(:) - integer :: ncompact,npart,icompactmax,ierr,ncompactlocal - integer :: i,j,k,n,icompact,nneigh_average - real :: rhoi,rhoj - real :: uradi,dradi,Ti,Tj,kappaBarj,kappaPartj,gmwj,gammaj,wkerni,grkerni - real :: kappaBari,kappaParti,gmwi,dx,dy,dz,rij2,rij,rij1,Wi,dWi - real :: dradxi,dradyi,dradzi,runix,runiy,runiz,R_rad,dT4 - real :: pmassj,hi,hi21,hi1,q,q2 - logical :: added_self - - npart = size(xyzh(1,:)) - nneigh_average = int(4./3.*pi*(radkern*hfact)**3) + 1 - icompactmax = int(1.2*nneigh_average*npart) - allocate(ivar(3,npart),stat=ierr) - if (ierr/=0) call fatal('get_diffusion_term_only','cannot allocate memory for ivar') - allocate(ijvar(icompactmax),stat=ierr) - if (ierr/=0) call fatal('get_diffusion_term_only','cannot allocate memory for ijvar') - - call get_compacted_neighbour_list(xyzh,ivar,ijvar,ncompact,ncompactlocal) - ! check for errors - if (ncompact <= 0 .or. ncompactlocal <= 0) then - call fatal('radiation_implicit','empty neighbour list - need to call set_linklist first?') - endif - - pmassj = massoftype(igas) - !$omp parallel do default(none)& - !$omp shared(ivar,ijvar,ncompact,unit_opacity,gradh,xyzh,unit_density,unit_ergg)& - !$omp shared(rho,utherm,pmassj,udist,lambda_fld)& - !$omp private(i,j,k,n,rhoi,rhoj,icompact,uradi,dradi,Ti,Tj,wkerni,grkerni,dT4)& - !$omp private(kappaBarj,kappaPartj,gmwj,gammaj,dx,dy,dz,rij,rij2,rij1,Wi,dWi)& - !$omp private(dradxi,dradyi,dradzi,runix,runiy,runiz,R_rad,hi,hi21,hi1,q,q2)& - !$omp private(kappaBari,kappaParti,gmwi,added_self) - loop_over_compact_list: do n = 1,ncompact - i = ivar(3,n) - ! print *, n,ncompact,utherm(i) - uradi = 0. - dradi = 0. - dradxi = 0. - dradyi = 0. - dradzi = 0. - rhoi = rho(i) - added_self = .false. - hi = xyzh(4,i) - hi21 = 1./(hi*hi) - hi1 = 1./hi - - call getopac_opdep(utherm(i)*unit_ergg,rhoi*unit_density,kappaBari,kappaParti,Ti,gmwi) - - loop_over_neighbours: do k = 1,ivar(1,n) - icompact = ivar(2,n) + k - ! print *, 'icompact',icompact - j = ijvar(icompact) - if (i == j) added_self = .true. - ! print *,'j',j - rhoj = rho(j) - ! print *, 'rhoj',rhoj - ! print *, 'xyzh(1,i)', xyzh(1,i) - ! print *, ' xyzh(1,j)', xyzh(1,j) - dx = xyzh(1,i) - xyzh(1,j) - ! print *, 'dx', dx - dy = xyzh(2,i) - xyzh(2,j) - dz = xyzh(3,i) - xyzh(3,j) - - rij2 = dx*dx + dy*dy + dz*dz + tiny(0.) - rij = sqrt(rij2) - rij1 = 1./rij - q = rij/hi - q2 = rij2*hi21 - - call get_kernel(q2,q,wkerni,grkerni) - !print *, 'got kernel' - Wi = wkerni*cnormk*hi21*hi1 - dWi = grkerni*cnormk*hi21*hi21*gradh(1,i) - - ! unit vector components - runix = dx/rij - runiy = dy/rij - runiz = dz/rij - - call getopac_opdep(utherm(j)*unit_ergg,rhoj*unit_density,kappaBarj,kappaPartj,Tj,gmwj) -! uradi = uradi + arad*pmassj*Tj**4.0d0*Wi/(rhoj)!*udist**3) ! why udist here? kern has h^-3 - ! print *, 'got opdep j' - - dT4 = Ti**4d0 - Tj**4d0 - ! dradxi = dradxi + pmassj*arad*dT4*dWi*runix/rhoj - ! dradyi = dradyi + pmassj*arad*dT4*dWi*runiy/rhoj - ! dradzi = dradzi + pmassj*arad*dT4*dWi*runiz/rhoj - enddo loop_over_neighbours - - ! print *, 'done neighbour loop for ', i,n - if (.not. added_self) then -! print *, "Has not added self in lambda hybrid" -! uradi = uradi + cnormk*hi1*hi21*pmassj*arad*Ti**4d0/rhoi ! add self contribution - endif - - dradi = sqrt(dradxi*dradxi + dradyi*dradyi + dradzi*dradzi) ! magnitude - if ( (uradi == 0d0) .or. (dradi == 0d0) ) then - R_rad = 0d0 - else - R_rad = dradi / (uradi*rhoi*kappaParti/unit_opacity) !code units - endif - - lambda_fld(i) = (2d0 + R_rad) / (6d0 + 3d0*R_rad + R_rad*R_rad) - enddo loop_over_compact_list - !$omp end parallel do - - end subroutine calc_lambda_hybrid end module radiation_implicit diff --git a/src/main/radiation_utils.f90 b/src/main/radiation_utils.f90 index 0aa06a6fe..dd701c892 100644 --- a/src/main/radiation_utils.f90 +++ b/src/main/radiation_utils.f90 @@ -417,7 +417,7 @@ subroutine get_opacity(opacity_type,density,temperature,kappa) real, intent(in) :: density, temperature real, intent(out) :: kappa integer, intent(in) :: opacity_type - real :: kapt,kapr,rho_cgs,Ti,gmwi,gammai,kapBar,kappaPart + real :: kapt,kapr,rho_cgs select case(opacity_type) case(1) diff --git a/src/main/readwrite_dumps_fortran.F90 b/src/main/readwrite_dumps_fortran.F90 index d30f2f004..28362db81 100644 --- a/src/main/readwrite_dumps_fortran.F90 +++ b/src/main/readwrite_dumps_fortran.F90 @@ -309,10 +309,10 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) ! masterthread: if (id==master) then ! open(unit=10,file=trim(dumpfile)//'info.dat') - ! write(10,'(6A16)') '# R', 'Gpot_cool','poten','gradP_cool', 'eos_vars(gasP)','eos_vars(gamma)' + ! write(10,'(6A16)') '# R', 'Gpot_cool','poten','gradP_cool' ! do i=1,nparttot ! write(10,'(6E16.5)') sqrt(xyzh(1,i)**2+xyzh(2,i)**2+xyzh(3,i)**2),Gpot_cool(i),poten(i),& - ! gradP_cool(i),eos_vars(igasP,i),eos_vars(igamma,i) + ! gradP_cool(i) ! enddo ! close(10) if (idtmax_frac==0) then @@ -409,9 +409,9 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) endif endif ! write urad to file (stamatellos + FLD) - if (icooling == 8 .and. doFLD) then - call write_array(1,urad_FLD,'urad',npart,k,ipass,idump,nums,ierrs(13)) - endif +! if (icooling == 8 .and. doFLD) then +! call write_array(1,urad_FLD,'urad',npart,k,ipass,idump,nums,ierrs(13)) +! endif ! smoothing length written as real*4 to save disk space call write_array(1,xyzh,xyzh_label,1,npart,k,ipass,idump,nums,ierrs(14),use_kind=4,index=4) diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 8b98f287e..8679970a7 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -1,4 +1,4 @@ - !--------------------------------------------------------------------------! +!--------------------------------------------------------------------------! ! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! ! Copyright (c) 2007-2023 The Authors (see AUTHORS) ! ! See LICENCE file for usage and distribution conditions ! From 1bca84ca928dec833d69ae654259e5e116c71e2c Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Fri, 19 Jan 2024 00:21:18 +1100 Subject: [PATCH 009/134] (windtunnel) add option to have wind only, no star --- src/main/inject_windtunnel.f90 | 19 ++++++++++++++----- src/setup/setup_windtunnel.f90 | 32 +++++++++++++++++--------------- 2 files changed, 31 insertions(+), 20 deletions(-) diff --git a/src/main/inject_windtunnel.f90 b/src/main/inject_windtunnel.f90 index 7c304db07..f73f32bf2 100644 --- a/src/main/inject_windtunnel.f90 +++ b/src/main/inject_windtunnel.f90 @@ -27,10 +27,13 @@ module inject character(len=*), parameter, public :: inject_type = 'windtunnel' public :: init_inject,inject_particles,write_options_inject,read_options_inject,& - set_default_options_inject + set_default_options_inject,windonly ! !--runtime settings for this module ! + + logical :: windonly = .false. + ! Main parameters: model MS6 from Ruffert & Arnett (1994) real, public :: v_inf = 1. real, public :: rho_inf = 1. @@ -48,7 +51,7 @@ module inject private real :: wind_rad,wind_x,psep,distance_between_layers,& time_between_layers,h_inf,u_inf - integer :: max_layers,max_particles,nodd,neven + integer :: max_layers,max_particles,nodd,neven,nstarpart logical :: first_run = .true. real, allocatable :: layer_even(:,:),layer_odd(:,:) @@ -72,6 +75,12 @@ subroutine init_inject(ierr) ierr = 0 + if (windonly) then + nstarpart = 0 + else + nstarpart = nstar + endif + u_inf = pres_inf / (rho_inf*(gamma-1.)) cs_inf = sqrt(gamma*pres_inf/rho_inf) mach = v_inf/cs_inf @@ -143,11 +152,11 @@ subroutine init_inject(ierr) endif h_inf = hfact*(pmass/rho_inf)**(1./3.) max_layers = int(wind_length*Rstar/distance_between_layers) - max_particles = int(max_layers*(nodd+neven)/2) + nstar + max_particles = int(max_layers*(nodd+neven)/2) + nstarpart time_between_layers = distance_between_layers/v_inf call print_summary(v_inf,cs_inf,rho_inf,pres_inf,mach,pmass,distance_between_layers,& - time_between_layers,max_layers,nstar,max_particles) + time_between_layers,max_layers,nstarpart,max_particles) if (max_particles > maxp) call fatal('windtunnel', 'maxp too small for this simulation, please increase MAXP!') @@ -212,7 +221,7 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& endif print *, np, ' particles (npart=', npart, '/', max_particles, ')' endif - call inject_or_update_particles(i_part+nstar+1, np, xyz, vxyz, h, u, .false.) + call inject_or_update_particles(i_part+nstarpart+1, np, xyz, vxyz, h, u, .false.) deallocate(xyz, vxyz, h, u) enddo diff --git a/src/setup/setup_windtunnel.f90 b/src/setup/setup_windtunnel.f90 index 2c8e20ba4..e5527dcbd 100644 --- a/src/setup/setup_windtunnel.f90 +++ b/src/setup/setup_windtunnel.f90 @@ -19,7 +19,7 @@ module setup use io, only:master,fatal use inject, only:init_inject,nstar,Rstar,lattice_type,handled_layers,& wind_radius,wind_injection_x,wind_length,& - rho_inf,pres_inf,v_inf + rho_inf,pres_inf,v_inf,windonly implicit none public :: setpart @@ -132,22 +132,24 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, vxyzu(:,:) = 0. ! Set polytropic star - allocate(r(nrhotab),den(nrhotab),pres(nrhotab)) - call rho_polytrope(gamma,polyk,Mstar,r,den,npts,rhocentre,set_polyk=.true.,Rstar=Rstar) - pres = polyk*den**gamma - rmin = r(1) - call set_star_density(lattice,id,master,rmin,Rstar,Mstar,hfact,& + if (.not. windonly) then + allocate(r(nrhotab),den(nrhotab),pres(nrhotab)) + call rho_polytrope(gamma,polyk,Mstar,r,den,npts,rhocentre,set_polyk=.true.,Rstar=Rstar) + pres = polyk*den**gamma + rmin = r(1) + call set_star_density(lattice,id,master,rmin,Rstar,Mstar,hfact,& npts,den,r,npart,npartoftype,massoftype,xyzh,& use_exactN,np,rhozero,npart_total,i_belong) ! Note: mass_is_set = .true., so np is not used - ! Set thermal energy - do i = 1,npart - ri = sqrt(dot_product(xyzh(1:3,i),xyzh(1:3,i))) - densi = yinterp(den(1:npts),r(1:npts),ri) - presi = yinterp(pres(1:npts),r(1:npts),ri) - vxyzu(4,i) = presi / ( (gamma-1.) * densi) - enddo - - deallocate(r,den,pres) + ! Set thermal energy + do i = 1,npart + ri = sqrt(dot_product(xyzh(1:3,i),xyzh(1:3,i))) + densi = yinterp(den(1:npts),r(1:npts),ri) + presi = yinterp(pres(1:npts),r(1:npts),ri) + vxyzu(4,i) = presi / ( (gamma-1.) * densi) + enddo + + deallocate(r,den,pres) + endif print*, "udist = ", udist, "; umass = ", umass, "; utime = ", utime From 494983bedc703f082f022526448078e441364260 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Tue, 23 Jan 2024 10:33:07 +0000 Subject: [PATCH 010/134] Added Modified Lombardi cooling method --- src/main/cooling_stamatellos.f90 | 40 ++++++++++++++++++++------------ 1 file changed, 25 insertions(+), 15 deletions(-) diff --git a/src/main/cooling_stamatellos.f90 b/src/main/cooling_stamatellos.f90 index 8033904e9..eb84fc4a8 100644 --- a/src/main/cooling_stamatellos.f90 +++ b/src/main/cooling_stamatellos.f90 @@ -30,13 +30,16 @@ module cooling_stamatellos subroutine init_star() use part, only:nptmass,xyzmh_ptmass + use io, only:fatal integer :: i,imin real :: rsink2,rsink2min rsink2min = 0d0 - if (nptmass == 0 .or. Lstar == 0.0) then + if (nptmass == 0 .or. ( Lstar == 0.0 .and. od_method /=4)) then isink_star = 0 ! no stellar heating print *, "No stellar heating." + elseif (od_method ==4 .and. nptmass == 0) then + call fatal('init star','od_method = 4 but there is no sink!',var='nptmass',ival=nptmass) elseif (nptmass == 1) then isink_star = 1 else @@ -58,7 +61,7 @@ end subroutine init_star ! subroutine cooling_S07(rhoi,ui,dudti_cool,xi,yi,zi,Tfloor,dudti_sph,dt,i) use io, only:warning - use physcon, only:steboltz,pi,solarl,Rg,kb_on_mh + use physcon, only:steboltz,pi,solarl,Rg,kb_on_mh,piontwo,rpiontwo use units, only:umass,udist,unit_density,unit_ergg,utime,unit_pressure use eos_stamatellos, only:getopac_opdep,getintenerg_opdep,gradP_cool,Gpot_cool,& duFLD,doFLD @@ -69,20 +72,21 @@ subroutine cooling_S07(rhoi,ui,dudti_cool,xi,yi,zi,Tfloor,dudti_sph,dt,i) real,intent(out) :: dudti_cool real :: coldensi,kappaBari,kappaParti,ri2 real :: gmwi,Tmini4,Ti,dudt_rad,Teqi,Hstam,HLom,du_tot + real :: cs2,Om2,Q3D,Hmod2 real :: tcool,ueqi,umini,tthermi,poti,presi,Hcomb,du_FLDi poti = Gpot_cool(i) du_FLDi = duFLD(i) + ri2 = (xi-xyzmh_ptmass(1,isink_star))**2d0 & + + (yi-xyzmh_ptmass(2,isink_star))**2d0 & + + (zi-xyzmh_ptmass(3,isink_star))**2d0 + ! Tfloor is from input parameters and is background heating ! Stellar heating if (isink_star > 0 .and. Lstar > 0.d0) then - ri2 = (xi-xyzmh_ptmass(1,isink_star))**2d0 & - + (yi-xyzmh_ptmass(2,isink_star))**2d0 & - + (zi-xyzmh_ptmass(3,isink_star))**2d0 - ri2 = ri2 *udist*udist ! Tfloor + stellar heating - Tmini4 = Tfloor**4d0 + (Lstar*solarl/(16d0*pi*steboltz*ri2)) + Tmini4 = Tfloor**4d0 + (Lstar*solarl/(16d0*pi*steboltz*ri2*udist*udist)) else Tmini4 = Tfloor**4d0 endif @@ -113,9 +117,18 @@ subroutine cooling_S07(rhoi,ui,dudti_cool,xi,yi,zi,Tfloor,dudti_sph,dt,i) ! Combined method HStam = sqrt(abs(poti*rhoi)/4.0d0/pi)*0.368d0/rhoi HLom = 1.014d0*presi/abs(gradP_cool(i))/rhoi - Hcomb = 1.0/sqrt((1.0d0/HLom)**2.0d0 + (1.0d0/HStam)**2.0d0) + Hcomb = 1.d0/sqrt((1.0d0/HLom)**2.0d0 + (1.0d0/HStam)**2.0d0) coldensi = Hcomb*rhoi - coldensi = coldensi*umass/udist/udist + coldensi = coldensi*umass/udist/udist ! physical units +case (4) +! Modified Lombardi method + HLom = presi/abs(gradP_cool(i))/rhoi + cs2 = presi/rhoi + Om2 = xyzmh_ptmass(4,isink_star)/(ri2**(1.5)) !NB we are using spherical radius here + Q3D = Om2/(4.d0*pi*rhoi) + Hmod2 = (cs2/Om2) * piontwo /(1d0 + (1d0/(rpiontwo*Q3D))) + Hcomb = 1.d0/sqrt((1.0d0/HLom)**2.0d0 + (1.0d0/Hmod2)) + coldensi = 1.014d0 * Hcomb *rhoi*umass/udist/udist ! physical units end select tcool = (coldensi**2d0)*kappaBari + (1.d0/kappaParti) ! physical units @@ -180,7 +193,7 @@ subroutine write_options_cooling_stamatellos(iunit) !N.B. Tfloor handled in cooling.F90 call write_inopt(eos_file,'EOS_file','File containing tabulated EOS values',iunit) - call write_inopt(od_method,'OD method','Method for estimating optical depth: (1) potential (2) pressure (3) combined',iunit) + call write_inopt(od_method,'OD method','Method for estimating optical depth: (1) Stamatellos(2) Lombardi (3) combined (4) modified Lombardi',iunit) call write_inopt(Lstar,'Lstar','Luminosity of host star for calculating Tmin (Lsun)',iunit) end subroutine write_options_cooling_stamatellos @@ -202,8 +215,8 @@ subroutine read_options_cooling_stamatellos(name,valstring,imatch,igotallstam,ie ngot = ngot + 1 case('OD method') read(valstring,*,iostat=ierr) od_method - if (od_method < 1 .or. od_method > 3) then - call fatal('cooling options','od_method must be 1, 2 or 3',var='od_method',ival=od_method) + if (od_method < 1 .or. od_method > 4) then + call fatal('cooling options','od_method must be 1, 2, 3 or 4',var='od_method',ival=od_method) endif ngot = ngot + 1 case('EOS_file') @@ -212,9 +225,6 @@ subroutine read_options_cooling_stamatellos(name,valstring,imatch,igotallstam,ie case default imatch = .false. end select - if (od_method /= 1 .and. od_method /= 2 .and. od_method /= 3) then - call warning('cooling_stamatellos','optical depth method unknown') - endif if (ngot >= 3) igotallstam = .true. From 6a5ccc527dbe4a5a4b0d7d6e0f4fdf00f4e186e2 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Mon, 29 Jan 2024 16:50:24 +0000 Subject: [PATCH 011/134] Added FLD as a runtime option for icooling=8 --- src/main/cooling.F90 | 2 +- src/main/cooling_stamatellos.f90 | 19 +++++++++++++++---- src/main/dens.F90 | 2 +- src/main/eos_stamatellos.f90 | 8 ++++++-- 4 files changed, 23 insertions(+), 8 deletions(-) diff --git a/src/main/cooling.F90 b/src/main/cooling.F90 index c9ffd8a27..6a77b5dd1 100644 --- a/src/main/cooling.F90 +++ b/src/main/cooling.F90 @@ -212,7 +212,7 @@ subroutine write_options_cooling(iunit) if (icooling > 0) call write_options_cooling_ism(iunit) else call write_inopt(icooling,'icooling','cooling function (0=off, 1=cooling library (step), 2=cooling library (force),'// & - '3=Gammie, 5,6=KI02, 7=powerlaw, 8=stamatellos)',iunit) + '3=Gammie, 5,6=KI02, 7=powerlaw, 8=polytropic approx)',iunit) select case(icooling) case(0,4,5,6) ! do nothing diff --git a/src/main/cooling_stamatellos.f90 b/src/main/cooling_stamatellos.f90 index eb84fc4a8..2422e363e 100644 --- a/src/main/cooling_stamatellos.f90 +++ b/src/main/cooling_stamatellos.f90 @@ -23,6 +23,7 @@ module cooling_stamatellos real, public :: Lstar ! in units of L_sun integer :: isink_star ! index of sink to use as illuminating star integer :: od_method = 1 ! default = Stamatellos+ 2007 method + integer :: fld_opt = 1 ! by default FLD is switched on public :: cooling_S07,write_options_cooling_stamatellos,read_options_cooling_stamatellos public :: init_star @@ -193,25 +194,26 @@ subroutine write_options_cooling_stamatellos(iunit) !N.B. Tfloor handled in cooling.F90 call write_inopt(eos_file,'EOS_file','File containing tabulated EOS values',iunit) - call write_inopt(od_method,'OD method','Method for estimating optical depth: (1) Stamatellos(2) Lombardi (3) combined (4) modified Lombardi',iunit) + call write_inopt(od_method,'OD method','Method for estimating optical depth: (1) Stamatellos (2) Lombardi (3) combined (4) modified Lombardi',iunit) call write_inopt(Lstar,'Lstar','Luminosity of host star for calculating Tmin (Lsun)',iunit) + call write_inopt(FLD_opt,'do FLD','Do FLD? (1) yes (0) no',iunit) end subroutine write_options_cooling_stamatellos subroutine read_options_cooling_stamatellos(name,valstring,imatch,igotallstam,ierr) use io, only:warning,fatal - use eos_stamatellos, only: eos_file + use eos_stamatellos, only: eos_file,doFLD character(len=*), intent(in) :: name,valstring logical, intent(out) :: imatch,igotallstam integer, intent(out) :: ierr integer, save :: ngot = 0 - imatch = .true. igotallstam = .false. ! cooling options are compulsory select case(trim(name)) case('Lstar') read(valstring,*,iostat=ierr) Lstar + if (Lstar < 0.) call fatal('Lstar','Luminosity cannot be negative') ngot = ngot + 1 case('OD method') read(valstring,*,iostat=ierr) od_method @@ -222,11 +224,20 @@ subroutine read_options_cooling_stamatellos(name,valstring,imatch,igotallstam,ie case('EOS_file') read(valstring,*,iostat=ierr) eos_file ngot = ngot + 1 + case('do FLD') + read(valstring,*,iostat=ierr) FLD_opt + if (FLD_opt < 0) call fatal('FLD_opt','FLD option out of range') + if (FLD_opt == 0) then + doFLD = .false. + elseif (FLD_opt == 1) then + doFLD = .true. + endif + ngot = ngot + 1 case default imatch = .false. end select - if (ngot >= 3) igotallstam = .true. + if (ngot >= 4) igotallstam = .true. end subroutine read_options_cooling_stamatellos diff --git a/src/main/dens.F90 b/src/main/dens.F90 index dc7f30f99..43a4995a0 100644 --- a/src/main/dens.F90 +++ b/src/main/dens.F90 @@ -268,7 +268,7 @@ subroutine densityiterate(icall,npart,nactive,xyzh,vxyzu,divcurlv,divcurlB,Bevol !$omp shared(thread_complete) & !$omp shared(ncomplete_mpi) & !$omp shared(icooling) & -!$omp shared(lambda_FLD,urad_FLD) & +!$omp shared(lambda_FLD,urad_FLD,doFLD) & !$omp reduction(+:nlocal) & !$omp private(do_export) & !$omp private(j) & diff --git a/src/main/eos_stamatellos.f90 b/src/main/eos_stamatellos.f90 index 63d8afd90..a9bcefde0 100644 --- a/src/main/eos_stamatellos.f90 +++ b/src/main/eos_stamatellos.f90 @@ -21,7 +21,7 @@ module eos_stamatellos real,allocatable,public :: optable(:,:,:) real,allocatable,public :: Gpot_cool(:),duFLD(:),gradP_cool(:),lambda_FLD(:),urad_FLD(:) !gradP_cool=gradP/rho character(len=25), public :: eos_file= 'myeos.dat' !default name of tabulated EOS file - logical,parameter,public :: doFLD = .True. + logical,public :: doFLD = .True. integer,public :: iunitst=19 integer,save :: nx,ny ! dimensions of optable read in @@ -40,7 +40,11 @@ subroutine init_S07cool() allocate(urad_FLD(npart)) urad_FLD(:) = 0d0 open (unit=iunitst,file='EOSinfo.dat',status='replace') - if (doFLD) print *, "Using Forgan+ 2009 hybrid cooling method (FLD)" + if (doFLD) then + print *, "Using Forgan+ 2009 hybrid cooling method (FLD)" + else + print *, "NOT using FLD. Using cooling only" + endif end subroutine init_S07cool subroutine finish_S07cool() From cc0567e6cd2f12ab012327364fbc34ed5b4840df Mon Sep 17 00:00:00 2001 From: Alison Young Date: Tue, 30 Jan 2024 15:37:53 +0000 Subject: [PATCH 012/134] Rearranged Modified Lombardi equation --- src/main/cooling_stamatellos.f90 | 25 ++++++++++++++++--------- 1 file changed, 16 insertions(+), 9 deletions(-) diff --git a/src/main/cooling_stamatellos.f90 b/src/main/cooling_stamatellos.f90 index 2422e363e..428b3b0b9 100644 --- a/src/main/cooling_stamatellos.f90 +++ b/src/main/cooling_stamatellos.f90 @@ -39,8 +39,8 @@ subroutine init_star() if (nptmass == 0 .or. ( Lstar == 0.0 .and. od_method /=4)) then isink_star = 0 ! no stellar heating print *, "No stellar heating." - elseif (od_method ==4 .and. nptmass == 0) then - call fatal('init star','od_method = 4 but there is no sink!',var='nptmass',ival=nptmass) + elseif (od_method == 4 .and. nptmass == 0) then + print *, "NO central star." elseif (nptmass == 1) then isink_star = 1 else @@ -79,9 +79,11 @@ subroutine cooling_S07(rhoi,ui,dudti_cool,xi,yi,zi,Tfloor,dudti_sph,dt,i) poti = Gpot_cool(i) du_FLDi = duFLD(i) - ri2 = (xi-xyzmh_ptmass(1,isink_star))**2d0 & - + (yi-xyzmh_ptmass(2,isink_star))**2d0 & - + (zi-xyzmh_ptmass(3,isink_star))**2d0 + if (isink_star > 0) then + ri2 = (xi-xyzmh_ptmass(1,isink_star))**2d0 & + + (yi-xyzmh_ptmass(2,isink_star))**2d0 & + + (zi-xyzmh_ptmass(3,isink_star))**2d0 + endif ! Tfloor is from input parameters and is background heating ! Stellar heating @@ -121,13 +123,18 @@ subroutine cooling_S07(rhoi,ui,dudti_cool,xi,yi,zi,Tfloor,dudti_sph,dt,i) Hcomb = 1.d0/sqrt((1.0d0/HLom)**2.0d0 + (1.0d0/HStam)**2.0d0) coldensi = Hcomb*rhoi coldensi = coldensi*umass/udist/udist ! physical units -case (4) + case (4) ! Modified Lombardi method HLom = presi/abs(gradP_cool(i))/rhoi cs2 = presi/rhoi - Om2 = xyzmh_ptmass(4,isink_star)/(ri2**(1.5)) !NB we are using spherical radius here - Q3D = Om2/(4.d0*pi*rhoi) - Hmod2 = (cs2/Om2) * piontwo /(1d0 + (1d0/(rpiontwo*Q3D))) + if (isink_star > 0 .and. ri2 > 0d0) then + Om2 = xyzmh_ptmass(4,isink_star)/(ri2**(1.5)) !NB we are using spherical radius here + else + Om2 = 0d0 + endif + Hmod2 = cs2 * piontwo / (Om2 + 8d0*rpiontwo*rhoi) + !Q3D = Om2/(4.d0*pi*rhoi) + !Hmod2 = (cs2/Om2) * piontwo /(1d0 + (1d0/(rpiontwo*Q3D))) Hcomb = 1.d0/sqrt((1.0d0/HLom)**2.0d0 + (1.0d0/Hmod2)) coldensi = 1.014d0 * Hcomb *rhoi*umass/udist/udist ! physical units end select From 1e9a9f9c0ee11a69cfc6760d7dc816294c792525 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Fri, 2 Feb 2024 12:21:55 +0000 Subject: [PATCH 013/134] Bug fix for Modified Lombardi cooling --- src/main/cooling_stamatellos.f90 | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/main/cooling_stamatellos.f90 b/src/main/cooling_stamatellos.f90 index 428b3b0b9..ec7d6bf14 100644 --- a/src/main/cooling_stamatellos.f90 +++ b/src/main/cooling_stamatellos.f90 @@ -36,11 +36,12 @@ subroutine init_star() real :: rsink2,rsink2min rsink2min = 0d0 - if (nptmass == 0 .or. ( Lstar == 0.0 .and. od_method /=4)) then - isink_star = 0 ! no stellar heating + + isink_star = 0 + if (od_method == 4 .and. nptmass == 0) then + print *, "NO central star and using od_method = 4" + elseif (nptmass == 0) then print *, "No stellar heating." - elseif (od_method == 4 .and. nptmass == 0) then - print *, "NO central star." elseif (nptmass == 1) then isink_star = 1 else @@ -54,7 +55,7 @@ subroutine init_star() isink_star = imin endif if (isink_star > 0) print *, "Using sink no. ", isink_star,& - "at (xyz)",xyzmh_ptmass(1:3,isink_star),"as illuminating star." + "at (xyz)",xyzmh_ptmass(1:3,isink_star)!"as illuminating star." end subroutine init_star ! From 51bdb87019d583287689c9870c23f9b473164302 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 20 Feb 2024 10:59:05 +0100 Subject: [PATCH 014/134] (CE-analysis) calculate planet sep and vel wrt origin if no ptmasses are present --- src/utils/analysis_common_envelope.f90 | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 6cd1c6c27..d1c4a59bd 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -128,7 +128,6 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) call prompt('Choose analysis type ',analysis_to_perform,1,41) endif - call reset_centreofmass(npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass) call adjust_corotating_velocities(npart,particlemass,xyzh,vxyzu,& xyzmh_ptmass,vxyz_ptmass,omega_corotate,dump_number) @@ -440,7 +439,7 @@ subroutine planet_rvm(time,particlemass,xyzh,vxyzu) real, intent(in) :: time,xyzh(:,:),vxyzu(:,:),particlemass character(len=17), allocatable :: columns(:) real, dimension(3) :: planet_com,planet_vel,sep,vel - real :: rhoi,rhoprev,sepi,si,smin,presi,Rthreshold + real :: rhoi,rhoprev,sepi,si,smin,presi,Rthreshold,xyz_origin(3),vxyz_origin(3) real, allocatable :: data_cols(:),mass(:),vthreshold(:) integer :: i,j,ncols,maxrho_ID,ientropy,Nmasks integer, save :: nplanet @@ -470,6 +469,14 @@ subroutine planet_rvm(time,particlemass,xyzh,vxyzu) if (dump_number == 0) call get_planetIDs(nplanet,planetIDs) isfulldump = (vxyzu(4,1) > 0.) + if (nptmass > 0) then + xyz_origin = xyzmh_ptmass(1:3,1) + vxyz_origin = vxyz_ptmass(1:3,1) + else + xyz_origin = (/0.,0.,0./) + vxyz_origin = (/0.,0.,0./) + endif + ! Find highest density and lowest entropy in planet rhoprev = 0. maxrho_ID = 1 @@ -492,11 +499,11 @@ subroutine planet_rvm(time,particlemass,xyzh,vxyzu) enddo planet_com = xyzh(1:3,maxrho_ID) - sep = planet_com - xyzmh_ptmass(1:3,1) + sep = planet_com - xyz_origin(1:3) if (isfulldump) then planet_vel = vxyzu(1:3,maxrho_ID) - vel = planet_vel - vxyz_ptmass(1:3,1) + vel = planet_vel - vxyz_origin(1:3) else vel = 0. smin = 0. From d49dd3142b24ab36aa87da55274a65162f8135a5 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 20 Feb 2024 21:01:15 +1100 Subject: [PATCH 015/134] (moddump_removeparticles) tweaks to prompt message --- src/utils/moddump_removeparticles_radius.f90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/utils/moddump_removeparticles_radius.f90 b/src/utils/moddump_removeparticles_radius.f90 index dd9ada106..057fbf6f8 100644 --- a/src/utils/moddump_removeparticles_radius.f90 +++ b/src/utils/moddump_removeparticles_radius.f90 @@ -17,7 +17,7 @@ module moddump ! :Dependencies: part, prompting ! - use part, only:delete_particles_outside_sphere + use part, only:delete_particles_outside_sphere,delete_particles_inside_radius use prompting, only:prompt implicit none @@ -47,13 +47,13 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) call prompt('Deleting particles inside a given radius ?',icutinside) call prompt('Deleting particles outside a given radius ?',icutoutside) if (icutinside) then - call prompt('Enter inward radius in au',inradius,0.) + call prompt('Enter inward radius in code units',inradius,0.) call prompt('Enter x coordinate of the center of that sphere',incenter(1)) call prompt('Enter y coordinate of the center of that sphere',incenter(2)) call prompt('Enter z coordinate of the center of that sphere',incenter(3)) endif if (icutoutside) then - call prompt('Enter outward radius in au',outradius,0.) + call prompt('Enter outward radius in code units',outradius,0.) call prompt('Enter x coordinate of the center of that sphere',outcenter(1)) call prompt('Enter y coordinate of the center of that sphere',outcenter(2)) call prompt('Enter z coordinate of the center of that sphere',outcenter(3)) @@ -62,13 +62,13 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) if (icutinside) then print*,'Phantommoddump: Remove particles inside a particular radius' print*,'Removing particles inside radius ',inradius - call delete_particles_outside_sphere(incenter,inradius,revert=.true.) + call delete_particles_inside_radius(incenter,inradius,npart,npartoftype) endif if (icutoutside) then print*,'Phantommoddump: Remove particles outside a particular radius' print*,'Removing particles outside radius ',outradius - call delete_particles_outside_sphere(outcenter,outradius) + call delete_particles_outside_sphere(outcenter,outradius,npart) endif end subroutine modify_dump From b3c219267aac46312c30f1ea943e132cecf942ba Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 20 Feb 2024 14:30:10 +0100 Subject: [PATCH 016/134] (windtunnel) add option to hold the gaseous sphere still inside the wind --- src/main/inject_windtunnel.f90 | 30 +++++++++++++++++++++++++++++- 1 file changed, 29 insertions(+), 1 deletion(-) diff --git a/src/main/inject_windtunnel.f90 b/src/main/inject_windtunnel.f90 index f73f32bf2..7c310811c 100644 --- a/src/main/inject_windtunnel.f90 +++ b/src/main/inject_windtunnel.f90 @@ -14,6 +14,7 @@ module inject ! :Runtime parameters: ! - lattice_type : *0: cubic distribution, 1: closepacked distribution* ! - handled_layers : *(integer) number of handled BHL wind layers* +! - hold_star : *1: subtract CM velocity of star particles at each timestep* ! - v_inf : *BHL wind speed* ! - Rstar : *BHL star radius (in accretion radii)* ! - BHL_radius : *radius of the wind cylinder (in star radii)* @@ -42,6 +43,7 @@ module inject integer, public :: nstar = 0 ! Particle-related parameters + integer, public :: hold_star = 0 integer, public :: lattice_type = 1 integer, public :: handled_layers = 4 real, public :: wind_radius = 30. @@ -228,6 +230,8 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& irrational_number_close_to_one = 3./pi dtinject = (irrational_number_close_to_one*time_between_layers)/utime + if ((hold_star>0) .and. (.not. windonly)) call subtract_star_vcom(nstarpart,vxyzu) + end subroutine inject_particles ! @@ -260,6 +264,26 @@ subroutine inject_or_update_particles(ifirst, n, position, velocity, h, u, bound end subroutine inject_or_update_particles +!----------------------------------------------------------------------- +!+ +! Subtracts centre-of-mass motion of star particles +! Assumes star particles have particle IDs 1 to nbulk +!+ +!----------------------------------------------------------------------- +subroutine subtract_star_vcom(nbulk,vxyzu) + integer, intent(in) :: nbulk + real, intent(inout) :: vxyzu(:,:) + real :: vstar(3) + integer :: i + + vstar = (/ sum(vxyzu(1,1:nbulk)), sum(vxyzu(2,1:nbulk)), sum(vxyzu(3,1:nbulk)) /) / real(nbulk) + do i=1,nbulk + vxyzu(1:3,i) = vxyzu(1:3,i) - vstar + enddo + +end subroutine subtract_star_vcom + + !----------------------------------------------------------------------- !+ ! Print summary of wind properties (assumes inputs are in code units) @@ -306,6 +330,7 @@ subroutine write_options_inject(iunit) call write_inopt(nstar,'nstar','No. of particles making up sphere',iunit) call write_inopt(lattice_type,'lattice_type','0: cubic distribution, 1: closepacked distribution',iunit) call write_inopt(handled_layers,'handled_layers','(integer) number of handled BHL wind layers',iunit) + call write_inopt(hold_star,'hold_star','1: subtract CM velocity of star particles at each timestep',iunit) call write_inopt(wind_radius,'BHL_radius','radius of the wind cylinder (in star radii)',iunit) call write_inopt(wind_injection_x,'wind_injection_x','x position of the wind injection boundary (in star radii)',iunit) call write_inopt(wind_length,'wind_length','crude wind length (in star radii)',iunit) @@ -368,9 +393,12 @@ subroutine read_options_inject(name,valstring,imatch,igotall,ierr) read(valstring,*,iostat=ierr) wind_length ngot = ngot + 1 if (wind_length <= 0.) call fatal(label,'wind_length must be positive') + case('hold_star') + read(valstring,*,iostat=ierr) hold_star + ngot = ngot + 1 end select - igotall = (ngot >= 10) + igotall = (ngot >= 11) end subroutine read_options_inject subroutine set_default_options_inject(flag) From 91867454b56413d74c0ac07a27cb87ec8fb2c05d Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 20 Feb 2024 14:30:28 +0100 Subject: [PATCH 017/134] (windtunnel) write number of star particles into infile --- src/setup/setup_windtunnel.f90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/setup/setup_windtunnel.f90 b/src/setup/setup_windtunnel.f90 index e5527dcbd..8bc49e23e 100644 --- a/src/setup/setup_windtunnel.f90 +++ b/src/setup/setup_windtunnel.f90 @@ -164,6 +164,7 @@ end subroutine setpart !----------------------------------------------------------------------- subroutine write_setupfile(filename) use infile_utils, only:write_inopt + use part, only:npart use dim, only:tagline use eos, only:gamma use setunits, only:write_options_units @@ -179,7 +180,7 @@ subroutine write_setupfile(filename) call write_options_units(iunit) write(iunit,"(/,a)") '# sphere settings' - call write_inopt(nstar,'nstar','number of particles resolving gas sphere',iunit) + call write_inopt(npart,'nstar','number of particles resolving gas sphere',iunit) ! note: npart is output of set_sphere call write_inopt(Mstar,'Mstar','sphere mass in code units',iunit) call write_inopt(Rstar,'Rstar','sphere radius in code units',iunit) From 4f9047525d2c6e2c4e34028c0bb57072c40d8c3e Mon Sep 17 00:00:00 2001 From: Alison Young Date: Wed, 21 Feb 2024 04:02:40 +0000 Subject: [PATCH 018/134] Adjust stellar heating estimate in cooling_stamatellos.f90 and write extra quantities to dump files --- src/main/cooling_stamatellos.f90 | 36 +++++++++++++----------- src/main/readwrite_dumps_fortran.F90 | 8 ++++-- src/utils/moddump_sphNG2phantom_disc.f90 | 6 ++-- 3 files changed, 27 insertions(+), 23 deletions(-) diff --git a/src/main/cooling_stamatellos.f90 b/src/main/cooling_stamatellos.f90 index ec7d6bf14..a9aaedf31 100644 --- a/src/main/cooling_stamatellos.f90 +++ b/src/main/cooling_stamatellos.f90 @@ -22,7 +22,7 @@ module cooling_stamatellos implicit none real, public :: Lstar ! in units of L_sun integer :: isink_star ! index of sink to use as illuminating star - integer :: od_method = 1 ! default = Stamatellos+ 2007 method + integer :: od_method = 4 ! default = Stamatellos+ 2007 method integer :: fld_opt = 1 ! by default FLD is switched on public :: cooling_S07,write_options_cooling_stamatellos,read_options_cooling_stamatellos public :: init_star @@ -66,7 +66,7 @@ subroutine cooling_S07(rhoi,ui,dudti_cool,xi,yi,zi,Tfloor,dudti_sph,dt,i) use physcon, only:steboltz,pi,solarl,Rg,kb_on_mh,piontwo,rpiontwo use units, only:umass,udist,unit_density,unit_ergg,utime,unit_pressure use eos_stamatellos, only:getopac_opdep,getintenerg_opdep,gradP_cool,Gpot_cool,& - duFLD,doFLD + duFLD,doFLD,ttherm_store,teqi_store,floor_energy use part, only:xyzmh_ptmass real,intent(in) :: rhoi,ui,dudti_sph,xi,yi,zi,Tfloor,dt @@ -74,7 +74,7 @@ subroutine cooling_S07(rhoi,ui,dudti_cool,xi,yi,zi,Tfloor,dudti_sph,dt,i) real,intent(out) :: dudti_cool real :: coldensi,kappaBari,kappaParti,ri2 real :: gmwi,Tmini4,Ti,dudt_rad,Teqi,Hstam,HLom,du_tot - real :: cs2,Om2,Q3D,Hmod2 + real :: cs2,Om2,Hmod2 real :: tcool,ueqi,umini,tthermi,poti,presi,Hcomb,du_FLDi poti = Gpot_cool(i) @@ -86,15 +86,6 @@ subroutine cooling_S07(rhoi,ui,dudti_cool,xi,yi,zi,Tfloor,dudti_sph,dt,i) + (zi-xyzmh_ptmass(3,isink_star))**2d0 endif -! Tfloor is from input parameters and is background heating -! Stellar heating - if (isink_star > 0 .and. Lstar > 0.d0) then -! Tfloor + stellar heating - Tmini4 = Tfloor**4d0 + (Lstar*solarl/(16d0*pi*steboltz*ri2*udist*udist)) - else - Tmini4 = Tfloor**4d0 - endif - ! get opacities & Ti for ui call getopac_opdep(ui*unit_ergg,rhoi*unit_density,kappaBari,kappaParti,& Ti,gmwi) @@ -140,6 +131,15 @@ subroutine cooling_S07(rhoi,ui,dudti_cool,xi,yi,zi,Tfloor,dudti_sph,dt,i) coldensi = 1.014d0 * Hcomb *rhoi*umass/udist/udist ! physical units end select +! Tfloor is from input parameters and is background heating +! Stellar heating + if (isink_star > 0 .and. Lstar > 0.d0) then +! Tfloor + stellar heating + Tmini4 = Tfloor**4d0 + exp(-coldensi*kappaBari)*(Lstar*solarl/(16d0*pi*steboltz*ri2*udist*udist)) + else + Tmini4 = Tfloor**4d0 + endif + tcool = (coldensi**2d0)*kappaBari + (1.d0/kappaParti) ! physical units dudt_rad = 4.d0*steboltz*(Tmini4 - Ti**4.d0)/tcool/unit_ergg*utime! code units @@ -154,12 +154,12 @@ subroutine cooling_S07(rhoi,ui,dudti_cool,xi,yi,zi,Tfloor,dudti_sph,dt,i) Teqi = Teqi/4.d0/steboltz Teqi = Teqi + Tmini4 - if (Teqi < Tmini4) then - Teqi = Tmini4**(1.0/4.0) - else +! if (Teqi < Tmini4) then +! Teqi = Tmini4**(1.0/4.0) +! else Teqi = Teqi**(1.0/4.0) - endif - +! endif + teqi_store(i) = Teqi call getintenerg_opdep(Teqi,rhoi*unit_density,ueqi) ueqi = ueqi/unit_ergg @@ -174,6 +174,8 @@ subroutine cooling_S07(rhoi,ui,dudti_cool,xi,yi,zi,Tfloor,dudti_sph,dt,i) tthermi = abs((ueqi - ui)/(du_tot)) endif + ttherm_store(i) = tthermi + if (tthermi == 0d0) then dudti_cool = 0.d0 ! condition if denominator above is zero else diff --git a/src/main/readwrite_dumps_fortran.F90 b/src/main/readwrite_dumps_fortran.F90 index 28362db81..b8f1bff67 100644 --- a/src/main/readwrite_dumps_fortran.F90 +++ b/src/main/readwrite_dumps_fortran.F90 @@ -244,7 +244,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) use krome_user, only:krome_nmols use part, only:gamma_chem,mu_chem,T_gas_cool #endif - use eos_stamatellos, only:gradP_cool,Gpot_cool,doFLD,urad_FLD + use eos_stamatellos, only:gradP_cool,doFLD,urad_FLD,ttherm_store,teqi_store real, intent(in) :: t character(len=*), intent(in) :: dumpfile integer, intent(in), optional :: iorder(:) @@ -409,9 +409,11 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) endif endif ! write urad to file (stamatellos + FLD) -! if (icooling == 8 .and. doFLD) then + if (icooling == 8) then ! .and. doFLD) then ! call write_array(1,urad_FLD,'urad',npart,k,ipass,idump,nums,ierrs(13)) -! endif + call write_array(1,teqi_store,'teqi',npart,k,ipass,idump,nums,ierrs(13)) + call write_array(1,ttherm_store,'ttherm',npart,k,ipass,idump,nums,ierrs(13)) + endif ! smoothing length written as real*4 to save disk space call write_array(1,xyzh,xyzh_label,1,npart,k,ipass,idump,nums,ierrs(14),use_kind=4,index=4) diff --git a/src/utils/moddump_sphNG2phantom_disc.f90 b/src/utils/moddump_sphNG2phantom_disc.f90 index 318bac487..b2db777da 100644 --- a/src/utils/moddump_sphNG2phantom_disc.f90 +++ b/src/utils/moddump_sphNG2phantom_disc.f90 @@ -32,7 +32,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) use prompting, only:prompt use physcon, only:au,gg use readwrite_dumps_fortran, only:dt_read_in_fortran - use timestep, only:time,dt,dtmax_max,dtmax_min,dtmax0 + use timestep, only:time,dt,dtmax_max,dtmax_min use centreofmass, only: reset_centreofmass integer, intent(inout) :: npart integer, intent(inout) :: npartoftype(:) @@ -97,7 +97,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) enddo close(iunit) - print *, 'dtmax0, dtmax_max,dtmax_min',dtmax0,dtmax_max,dtmax_min + print *, 'dtmax_max,dtmax_min',dtmax_max,dtmax_min newutime = sqrt(au**3/(gg*umass)) print *, "newutime/old", newutime/utime time = time * utime / newutime @@ -177,7 +177,7 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) 'nptmass:', nptmass print *, 'gamma=', gamma print *, 'Timestep info:' - print *, 'dtmax0, dtmax_max,dtmax_min', dtmax0,dtmax_max,dtmax_min + print *, 'dtmax_max,dtmax_min', dtmax_max,dtmax_min print *, 'utime=', utime return From 1313236641eddf72955fdb25537bc259c9388793 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Wed, 21 Feb 2024 04:05:26 +0000 Subject: [PATCH 019/134] Corrected sink read in moddump_sphNG2phantom_disc.f90 --- src/utils/moddump_sphNG2phantom_disc.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/utils/moddump_sphNG2phantom_disc.f90 b/src/utils/moddump_sphNG2phantom_disc.f90 index b2db777da..8e06851a5 100644 --- a/src/utils/moddump_sphNG2phantom_disc.f90 +++ b/src/utils/moddump_sphNG2phantom_disc.f90 @@ -82,9 +82,9 @@ subroutine modify_dump(npart,npartoftype,massoftype,xyzh,vxyzu) nptmass = nptmass + npt do i=1,npt read (iunit,*) junk - read (iunit,'(10E15.6)') (xyzmh_ptmass(j,nptmass),j=1,10) + read (iunit,'(10E15.6)') (xyzmh_ptmass(j,i),j=1,10) read (iunit,*) junk - read (iunit,'(3E15.6)') (vxyz_ptmass(j,nptmass),j=1,3) + read (iunit,'(3E15.6)') (vxyz_ptmass(j,i),j=1,3) enddo close(iunit) endif From 3971f1b9ef4d7d4dfd3f0599a460595bcb55360b Mon Sep 17 00:00:00 2001 From: Alison Young Date: Wed, 21 Feb 2024 06:38:41 +0000 Subject: [PATCH 020/134] Fixes for icooling=8 --- src/main/eos_stamatellos.f90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/main/eos_stamatellos.f90 b/src/main/eos_stamatellos.f90 index a9bcefde0..f20f99075 100644 --- a/src/main/eos_stamatellos.f90 +++ b/src/main/eos_stamatellos.f90 @@ -20,8 +20,9 @@ module eos_stamatellos implicit none real,allocatable,public :: optable(:,:,:) real,allocatable,public :: Gpot_cool(:),duFLD(:),gradP_cool(:),lambda_FLD(:),urad_FLD(:) !gradP_cool=gradP/rho + real,allocatable,public :: ttherm_store(:),teqi_store(:) character(len=25), public :: eos_file= 'myeos.dat' !default name of tabulated EOS file - logical,public :: doFLD = .True. + logical,public :: doFLD = .True., floor_energy = .False. integer,public :: iunitst=19 integer,save :: nx,ny ! dimensions of optable read in @@ -38,6 +39,8 @@ subroutine init_S07cool() allocate(duFLD(npart)) allocate(lambda_fld(npart)) allocate(urad_FLD(npart)) + allocate(ttherm_store(npart)) + allocate(teqi_store(npart)) urad_FLD(:) = 0d0 open (unit=iunitst,file='EOSinfo.dat',status='replace') if (doFLD) then @@ -54,6 +57,8 @@ subroutine finish_S07cool() if (allocated(duFLD)) deallocate(duFLD) if (allocated(lambda_fld)) deallocate(lambda_fld) if (allocated(urad_FLD)) deallocate(urad_FLD) + if (allocated(ttherm_store)) deallocate(ttherm_store) + if (allocated(teqi_store)) deallocate(teqi_store) close(iunitst) end subroutine finish_S07cool From 7d85592eb990dcca4b08a4083e8f433b1d45828d Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Wed, 21 Feb 2024 16:39:46 +0100 Subject: [PATCH 021/134] (windtunnel) subtract CM velocity of star excluding ablated particles --- src/main/inject_windtunnel.f90 | 31 ++++++++++++++++++++++--------- 1 file changed, 22 insertions(+), 9 deletions(-) diff --git a/src/main/inject_windtunnel.f90 b/src/main/inject_windtunnel.f90 index 7c310811c..d69b2cc5f 100644 --- a/src/main/inject_windtunnel.f90 +++ b/src/main/inject_windtunnel.f90 @@ -230,7 +230,7 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& irrational_number_close_to_one = 3./pi dtinject = (irrational_number_close_to_one*time_between_layers)/utime - if ((hold_star>0) .and. (.not. windonly)) call subtract_star_vcom(nstarpart,vxyzu) + if ((hold_star>0) .and. (.not. windonly)) call subtract_star_vcom(nstarpart,xyzh,vxyzu) end subroutine inject_particles @@ -267,19 +267,32 @@ end subroutine inject_or_update_particles !----------------------------------------------------------------------- !+ ! Subtracts centre-of-mass motion of star particles -! Assumes star particles have particle IDs 1 to nbulk +! Assumes star particles have particle IDs 1 to nsphere !+ !----------------------------------------------------------------------- -subroutine subtract_star_vcom(nbulk,vxyzu) - integer, intent(in) :: nbulk +subroutine subtract_star_vcom(nsphere,xyzh,vxyzu) + integer, intent(in) :: nsphere + real, intent(in) :: xyzh(:,:) real, intent(inout) :: vxyzu(:,:) real :: vstar(3) - integer :: i - - vstar = (/ sum(vxyzu(1,1:nbulk)), sum(vxyzu(2,1:nbulk)), sum(vxyzu(3,1:nbulk)) /) / real(nbulk) - do i=1,nbulk - vxyzu(1:3,i) = vxyzu(1:3,i) - vstar + integer :: i,nbulk + +! vstar = (/ sum(vxyzu(1,1:nsphere)), sum(vxyzu(2,1:nsphere)), sum(vxyzu(3,1:nsphere)) /) / real(nsphere) + nbulk = 0 + vstar = 0. + do i=1,nsphere + if (xyzh(1,i) < 2.*Rstar) then + vstar = vstar + vxyzu(1:3,i) + nbulk = nbulk + 1 + endif enddo + vstar = vstar/real(nbulk) + + do i=1,nsphere + if (xyzh(1,i) < 2.*Rstar) then + vxyzu(1:3,i) = vxyzu(1:3,i) - vstar + endif +enddo end subroutine subtract_star_vcom From 69eb93e109d94ec2b8659fafc45684bea4193786 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Wed, 21 Feb 2024 18:07:50 +0100 Subject: [PATCH 022/134] (windtunnel) add call to relax_star when setting polytrope sphere --- src/setup/setup_windtunnel.f90 | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/setup/setup_windtunnel.f90 b/src/setup/setup_windtunnel.f90 index 8bc49e23e..dda592701 100644 --- a/src/setup/setup_windtunnel.f90 +++ b/src/setup/setup_windtunnel.f90 @@ -40,6 +40,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use eos, only:ieos,gmw use setstar_utils,only:set_star_density use rho_profile, only:rho_polytrope + use relaxstar, only:relax_star use extern_densprofile, only:nrhotab use physcon, only:solarm,solarr use units, only:udist,umass,utime,set_units,unit_velocity,unit_density,unit_pressure @@ -57,9 +58,9 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, real, intent(inout) :: time character(len=20), intent(in) :: fileprefix real :: rhocentre,rmin,pmass,densi,presi,ri - real, allocatable :: r(:),den(:),pres(:) - integer :: ierr,npts,np,i - logical :: use_exactN,setexists + real, allocatable :: r(:),den(:),pres(:),Xfrac(:),Yfrac(:),mu(:) + integer :: ierr,ierr_relax,npts,np,i + logical :: use_exactN,setexists,use_var_comp character(len=30) :: lattice character(len=120) :: setupfile @@ -140,6 +141,10 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, call set_star_density(lattice,id,master,rmin,Rstar,Mstar,hfact,& npts,den,r,npart,npartoftype,massoftype,xyzh,& use_exactN,np,rhozero,npart_total,i_belong) ! Note: mass_is_set = .true., so np is not used + + use_var_comp = .false. + call relax_star(npts,den,pres,r,npart,xyzh,use_var_comp,Xfrac,Yfrac,mu,ierr_relax) + ! Set thermal energy do i = 1,npart ri = sqrt(dot_product(xyzh(1:3,i),xyzh(1:3,i))) From 1d0327b458644494a3a8fc7e0f4921ab7dd7ad41 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Wed, 28 Feb 2024 15:32:54 +0000 Subject: [PATCH 023/134] Changes to write opacity to dump (icooling=8) --- src/main/cooling_stamatellos.f90 | 29 ++++++++++++++-------------- src/main/eos_stamatellos.f90 | 4 +++- src/main/readwrite_dumps_fortran.F90 | 2 ++ 3 files changed, 20 insertions(+), 15 deletions(-) diff --git a/src/main/cooling_stamatellos.f90 b/src/main/cooling_stamatellos.f90 index a9aaedf31..beedaf568 100644 --- a/src/main/cooling_stamatellos.f90 +++ b/src/main/cooling_stamatellos.f90 @@ -66,7 +66,7 @@ subroutine cooling_S07(rhoi,ui,dudti_cool,xi,yi,zi,Tfloor,dudti_sph,dt,i) use physcon, only:steboltz,pi,solarl,Rg,kb_on_mh,piontwo,rpiontwo use units, only:umass,udist,unit_density,unit_ergg,utime,unit_pressure use eos_stamatellos, only:getopac_opdep,getintenerg_opdep,gradP_cool,Gpot_cool,& - duFLD,doFLD,ttherm_store,teqi_store,floor_energy + duFLD,doFLD,ttherm_store,teqi_store,opac_store use part, only:xyzmh_ptmass real,intent(in) :: rhoi,ui,dudti_sph,xi,yi,zi,Tfloor,dt @@ -75,7 +75,7 @@ subroutine cooling_S07(rhoi,ui,dudti_cool,xi,yi,zi,Tfloor,dudti_sph,dt,i) real :: coldensi,kappaBari,kappaParti,ri2 real :: gmwi,Tmini4,Ti,dudt_rad,Teqi,Hstam,HLom,du_tot real :: cs2,Om2,Hmod2 - real :: tcool,ueqi,umini,tthermi,poti,presi,Hcomb,du_FLDi + real :: opac,ueqi,umini,tthermi,poti,presi,Hcomb,du_FLDi poti = Gpot_cool(i) du_FLDi = duFLD(i) @@ -140,25 +140,26 @@ subroutine cooling_S07(rhoi,ui,dudti_cool,xi,yi,zi,Tfloor,dudti_sph,dt,i) Tmini4 = Tfloor**4d0 endif - tcool = (coldensi**2d0)*kappaBari + (1.d0/kappaParti) ! physical units - dudt_rad = 4.d0*steboltz*(Tmini4 - Ti**4.d0)/tcool/unit_ergg*utime! code units + opac = (coldensi**2d0)*kappaBari + (1.d0/kappaParti) ! physical units + opac_store(i) = opac + dudt_rad = 4.d0*steboltz*(Tmini4 - Ti**4.d0)/opac/unit_ergg*utime! code units if (doFLD) then ! include term from FLD - Teqi = (du_FLDi + dudti_sph) *tcool*unit_ergg/utime ! physical units + Teqi = (du_FLDi + dudti_sph) *opac*unit_ergg/utime ! physical units du_tot = dudti_sph + dudt_rad + du_FLDi else - Teqi = dudti_sph*tcool*unit_ergg/utime + Teqi = dudti_sph*opac*unit_ergg/utime du_tot = dudti_sph + dudt_rad endif - + Teqi = Teqi/4.d0/steboltz Teqi = Teqi + Tmini4 -! if (Teqi < Tmini4) then -! Teqi = Tmini4**(1.0/4.0) -! else + if (Teqi < Tmini4) then + Teqi = Tmini4**(1.0/4.0) + else Teqi = Teqi**(1.0/4.0) -! endif + endif teqi_store(i) = Teqi call getintenerg_opdep(Teqi,rhoi*unit_density,ueqi) ueqi = ueqi/unit_ergg @@ -183,11 +184,11 @@ subroutine cooling_S07(rhoi,ui,dudti_cool,xi,yi,zi,Tfloor,dudti_sph,dt,i) endif if (isnan(dudti_cool)) then - print *, "kappaBari=",kappaBari, "kappaParti=",kappaParti +! print *, "kappaBari=",kappaBari, "kappaParti=",kappaParti print *, "rhoi=",rhoi, "Ti=", Ti - print *, "tcool=",tcool,"coldensi=",coldensi,"dudti_sph",dudti_sph + print *, "opac=",opac,"coldensi=",coldensi,"dudti_sph",dudti_sph print *, "dt=",dt,"tthermi=", tthermi,"umini=", umini - print *, "dudt_rad=", dudt_rad + print *, "dudt_rad=", dudt_rad ,"dudt_dlf=",du_fldi,"ueqi=",ueqi,"ui=",ui call warning("In Stamatellos cooling","dudticool=NaN. ui",val=ui) stop else if (dudti_cool < 0.d0 .and. abs(dudti_cool) > ui/dt) then diff --git a/src/main/eos_stamatellos.f90 b/src/main/eos_stamatellos.f90 index f20f99075..203570437 100644 --- a/src/main/eos_stamatellos.f90 +++ b/src/main/eos_stamatellos.f90 @@ -20,7 +20,7 @@ module eos_stamatellos implicit none real,allocatable,public :: optable(:,:,:) real,allocatable,public :: Gpot_cool(:),duFLD(:),gradP_cool(:),lambda_FLD(:),urad_FLD(:) !gradP_cool=gradP/rho - real,allocatable,public :: ttherm_store(:),teqi_store(:) + real,allocatable,public :: ttherm_store(:),teqi_store(:),opac_store(:) character(len=25), public :: eos_file= 'myeos.dat' !default name of tabulated EOS file logical,public :: doFLD = .True., floor_energy = .False. integer,public :: iunitst=19 @@ -41,6 +41,7 @@ subroutine init_S07cool() allocate(urad_FLD(npart)) allocate(ttherm_store(npart)) allocate(teqi_store(npart)) + allocate(opac_store(npart)) urad_FLD(:) = 0d0 open (unit=iunitst,file='EOSinfo.dat',status='replace') if (doFLD) then @@ -59,6 +60,7 @@ subroutine finish_S07cool() if (allocated(urad_FLD)) deallocate(urad_FLD) if (allocated(ttherm_store)) deallocate(ttherm_store) if (allocated(teqi_store)) deallocate(teqi_store) + if (allocated(opac_store)) deallocate(opac_store) close(iunitst) end subroutine finish_S07cool diff --git a/src/main/readwrite_dumps_fortran.F90 b/src/main/readwrite_dumps_fortran.F90 index b8f1bff67..5628665b1 100644 --- a/src/main/readwrite_dumps_fortran.F90 +++ b/src/main/readwrite_dumps_fortran.F90 @@ -245,6 +245,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) use part, only:gamma_chem,mu_chem,T_gas_cool #endif use eos_stamatellos, only:gradP_cool,doFLD,urad_FLD,ttherm_store,teqi_store + use eos_stamatellos, only:opac_store real, intent(in) :: t character(len=*), intent(in) :: dumpfile integer, intent(in), optional :: iorder(:) @@ -413,6 +414,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) ! call write_array(1,urad_FLD,'urad',npart,k,ipass,idump,nums,ierrs(13)) call write_array(1,teqi_store,'teqi',npart,k,ipass,idump,nums,ierrs(13)) call write_array(1,ttherm_store,'ttherm',npart,k,ipass,idump,nums,ierrs(13)) + call write_array(1,opac_store,'opacity',npart,k,ipass,idump,nums,ierrs(13)) endif ! smoothing length written as real*4 to save disk space From c67364c12b2bc9cafa92adb8bb8ea29e09536b30 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Mon, 15 Apr 2024 14:55:12 +0100 Subject: [PATCH 024/134] Edits to analysis_disc_stresses.f90 for variable gamma (eos = 21) and more accurate H --- src/main/cooling_stamatellos.f90 | 6 +- src/main/readwrite_dumps_fortran.F90 | 4 +- src/utils/analysis_disc_stresses.f90 | 92 +++++++++++++++++++++------- 3 files changed, 75 insertions(+), 27 deletions(-) diff --git a/src/main/cooling_stamatellos.f90 b/src/main/cooling_stamatellos.f90 index beedaf568..5d5223344 100644 --- a/src/main/cooling_stamatellos.f90 +++ b/src/main/cooling_stamatellos.f90 @@ -205,7 +205,8 @@ subroutine write_options_cooling_stamatellos(iunit) !N.B. Tfloor handled in cooling.F90 call write_inopt(eos_file,'EOS_file','File containing tabulated EOS values',iunit) - call write_inopt(od_method,'OD method','Method for estimating optical depth: (1) Stamatellos (2) Lombardi (3) combined (4) modified Lombardi',iunit) + call write_inopt(od_method,'OD method','Method for estimating optical depth: (1)'& + 'Stamatellos (2) Lombardi (3) combined (4) modified Lombardi',iunit) call write_inopt(Lstar,'Lstar','Luminosity of host star for calculating Tmin (Lsun)',iunit) call write_inopt(FLD_opt,'do FLD','Do FLD? (1) yes (0) no',iunit) @@ -229,7 +230,8 @@ subroutine read_options_cooling_stamatellos(name,valstring,imatch,igotallstam,ie case('OD method') read(valstring,*,iostat=ierr) od_method if (od_method < 1 .or. od_method > 4) then - call fatal('cooling options','od_method must be 1, 2, 3 or 4',var='od_method',ival=od_method) + call fatal('cooling options','od_method must be 1, 2, 3 or 4', & + var='od_method',ival=od_method) endif ngot = ngot + 1 case('EOS_file') diff --git a/src/main/readwrite_dumps_fortran.F90 b/src/main/readwrite_dumps_fortran.F90 index 5628665b1..28b276c0b 100644 --- a/src/main/readwrite_dumps_fortran.F90 +++ b/src/main/readwrite_dumps_fortran.F90 @@ -1286,9 +1286,9 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto if (eos_outputs_gasP(ieos) .or. eos_is_non_ideal(ieos)) then call read_array(eos_vars(igasP,:),eos_vars_label(igasP),got_gasP,ik,i1,i2,noffset,idisk1,tag,match,ierr) endif - if (eos_is_non_ideal(ieos)) then +! if (eos_is_non_ideal(ieos)) then call read_array(eos_vars(itemp,:),eos_vars_label(itemp),got_temp,ik,i1,i2,noffset,idisk1,tag,match,ierr) - endif + ! endif call read_array(eos_vars(iX,:),eos_vars_label(iX),got_x,ik,i1,i2,noffset,idisk1,tag,match,ierr) call read_array(eos_vars(iZ,:),eos_vars_label(iZ),got_z,ik,i1,i2,noffset,idisk1,tag,match,ierr) call read_array(eos_vars(imu,:),eos_vars_label(imu),got_mu,ik,i1,i2,noffset,idisk1,tag,match,ierr) diff --git a/src/utils/analysis_disc_stresses.f90 b/src/utils/analysis_disc_stresses.f90 index ffb966aab..f2d546564 100644 --- a/src/utils/analysis_disc_stresses.f90 +++ b/src/utils/analysis_disc_stresses.f90 @@ -6,7 +6,8 @@ !--------------------------------------------------------------------------! module analysis ! -! Analysis routine for discs by DF, adapted from a routine by CJN +! Analysis routine for discs by DF, adapted from a routine by CJN. +! Edited for use with variable gammai and mui and more accurate alpha_ss calc by AKY ! ! :References: None ! @@ -28,7 +29,7 @@ module analysis real :: rin, rout,dr integer, allocatable,dimension(:) :: ipartbin real, allocatable,dimension(:) :: rad,ninbin,sigma,csbin,vrbin,vphibin, omega - real, allocatable,dimension(:) :: H, toomre_q,epicyc + real, allocatable,dimension(:) :: H, toomre_q,epicyc,part_scaleheight real, allocatable,dimension(:) :: alpha_reyn,alpha_grav,alpha_mag,alpha_art real, allocatable,dimension(:) :: rpart,phipart,vrpart,vphipart, gr,gphi,Br,Bphi real, allocatable,dimension(:,:) :: gravxyz @@ -42,7 +43,7 @@ module analysis subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) use io, only:fatal - use part, only:gravity,mhd + use part, only:gravity,mhd,eos_vars character(len=*), intent(in) :: dumpfile real, intent(in) :: xyzh(:,:),vxyzu(:,:) @@ -82,7 +83,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) call transform_to_cylindrical(npart,xyzh,vxyzu) ! Bin particles by radius - call radial_binning(npart,xyzh,vxyzu,pmass) + call radial_binning(npart,xyzh,vxyzu,pmass,eos_vars) ! Calculate stresses call calc_stresses(npart,xyzh,vxyzu,pmass) @@ -350,18 +351,21 @@ end subroutine transform_to_cylindrical !+ !--------------------------------------------------------------- -subroutine radial_binning(npart,xyzh,vxyzu,pmass) - use physcon, only:pi - use eos, only: gamma +subroutine radial_binning(npart,xyzh,vxyzu,pmass,eos_vars) + use physcon, only:pi,kb_on_mh + use eos, only:gamma,ieos + use part, only:itemp,imu + use units, only:udist implicit none integer,intent(in) :: npart real,intent(in) :: pmass - real,intent(in) :: xyzh(:,:),vxyzu(:,:) + real,intent(in) :: xyzh(:,:),vxyzu(:,:),eos_vars(:,:) - integer :: ibin,ipart,nbinned + integer :: ibin,ipart,nbinned,iallocerr real :: area + real,allocatable :: zsetgas(:,:) print '(a,I4)', 'Carrying out radial binning, number of bins: ',nbins @@ -373,6 +377,7 @@ subroutine radial_binning(npart,xyzh,vxyzu,pmass) allocate(omega(nbins)) allocate(vrbin(nbins)) allocate(vphibin(nbins)) + allocate(part_scaleheight(nbins)) ipartbin(:) = 0 ninbin(:) = 0.0 @@ -381,6 +386,15 @@ subroutine radial_binning(npart,xyzh,vxyzu,pmass) omega(:) = 0.0 vrbin(:) = 0.0 vphibin(:) = 0.0 + part_scaleheight(:) = 0.0 + + allocate(zsetgas(npart,nbins),stat=iallocerr) + ! If you don't have enough memory to allocate zsetgas, then calculate H the slow way with less memory. + if (iallocerr/=0) then + write(*,'(/,a)') ' WARNING: Could not allocate memory for array zsetgas!' + write(*,'(a)') ' (It possibly requires too much memory)' + write(*,'(a,/)') ' Try calculate scaleheight the slow way.' + endif ! Set up radial bins @@ -409,8 +423,14 @@ subroutine radial_binning(npart,xyzh,vxyzu,pmass) ninbin(ibin) = ninbin(ibin) +1 ipartbin(ipart) = ibin - - csbin(ibin) = csbin(ibin) + sqrt(gamma*(gamma-1)*vxyzu(4,ipart)) + if (ieos==21) then + csbin(ibin) = csbin(ibin) + sqrt(kb_on_mh * eos_vars(itemp,ipart) / eos_vars(imu,ipart)) + if (csbin(ibin) == 0) then + print *, eos_vars(itemp,ipart) + endif + else + csbin(ibin) = csbin(ibin) + sqrt(gamma*(gamma-1)*vxyzu(4,ipart)) + endif area = pi*((rad(ibin)+0.5*dr)**2-(rad(ibin)- 0.5*dr)**2) sigma(ibin) = sigma(ibin) + pmass/area @@ -418,11 +438,13 @@ subroutine radial_binning(npart,xyzh,vxyzu,pmass) vrbin(ibin) = vrbin(ibin) + vrpart(ipart) vphibin(ibin) = vphibin(ibin) + vphipart(ipart) omega(ibin) = omega(ibin) + vphipart(ipart)/rad(ibin) - + zsetgas(int(ninbin(ibin)),ibin) = xyzh(3,ipart) endif enddo + call calculate_H(nbins,part_scaleheight,zsetgas,int(ninbin)) + part_scaleheight(:) = part_scaleheight(:) print*, nbinned, ' particles have been binned' where(ninbin(:)/=0) @@ -443,11 +465,11 @@ end subroutine radial_binning !+ !-------------------------------------------------------------- subroutine calc_stresses(npart,xyzh,vxyzu,pmass) - use physcon, only: pi,gg + use physcon, only: pi,gg,kb_on_mh use units, only: print_units, umass,udist,utime,unit_velocity,unit_density,unit_Bfield use dim, only: gravity - use part, only: mhd,rhoh,alphaind - use eos, only: gamma + use part, only: mhd,rhoh,alphaind,eos_vars,imu,itemp + use eos, only: gamma,ieos implicit none @@ -481,7 +503,9 @@ subroutine calc_stresses(npart,xyzh,vxyzu,pmass) call print_units sigma(:) = sigma(:)*umass/(udist*udist) - csbin(:) = csbin(:)*unit_velocity + if (ieos /= 21) then + csbin(:) = csbin(:)*unit_velocity + endif omega(:) = omega(:)/utime Keplog = 1.5 @@ -500,9 +524,8 @@ subroutine calc_stresses(npart,xyzh,vxyzu,pmass) do ipart=1,npart ibin = ipartbin(ipart) - if (ibin<=0) cycle - - cs2 = gamma*(gamma-1)*vxyzu(4,ipart)*unit_velocity*unit_velocity + if (ibin<=0) cycle + dvr = (vrpart(ipart) - vrbin(ibin))*unit_velocity dvphi = (vphipart(ipart) -vphibin(ibin))*unit_velocity @@ -510,6 +533,7 @@ subroutine calc_stresses(npart,xyzh,vxyzu,pmass) alpha_reyn(ibin) = alpha_reyn(ibin) + dvr*dvphi +! Handle constant alpha_sph alpha_art(ibin) = alpha_art(ibin) + alphaind(1,ipart)*xyzh(4,ipart)*udist if (gravity) alpha_grav(ibin) = alpha_grav(ibin) + gr(ipart)*gphi(ipart)/rhopart @@ -587,7 +611,7 @@ subroutine write_radial_data(iunit,output,time) print '(a,a)', 'Writing to file ',output open(iunit,file=output) write(iunit,'("# Disc Stress data at t = ",es20.12)') time - write(iunit,"('#',11(1x,'[',i2.2,1x,a11,']',2x))") & + write(iunit,"('#',12(1x,'[',i2.2,1x,a11,']',2x))") & 1,'radius (AU)', & 2,'sigma (cgs)', & 3,'cs (cgs)', & @@ -598,12 +622,13 @@ subroutine write_radial_data(iunit,output,time) 8,'alpha_reyn',& 9,'alpha_grav',& 10,'alpha_mag',& - 11,'alpha_art' + 11,'alpha_art',& + 12,'particle H (au)' do ibin=1,nbins - write(iunit,'(11(es18.10,1X))') rad(ibin),sigma(ibin),csbin(ibin), & + write(iunit,'(12(es18.10,1X))') rad(ibin),sigma(ibin),csbin(ibin), & omega(ibin),epicyc(ibin),H(ibin), abs(toomre_q(ibin)),alpha_reyn(ibin), & - alpha_grav(ibin),alpha_mag(ibin),alpha_art(ibin) + alpha_grav(ibin),alpha_mag(ibin),alpha_art(ibin),part_scaleheight(ibin) enddo close(iunit) @@ -612,6 +637,26 @@ subroutine write_radial_data(iunit,output,time) end subroutine write_radial_data +subroutine calculate_H(nbin,H,zsetgas,ninbin) +! copied from utils disc + integer, intent(in) :: nbin + real, intent(out) :: H(:) + real, intent(in) :: zsetgas(:,:) + integer, intent(in) :: ninbin(:) + integer :: ii + real :: meanzii + + do ii = 1,nbin + if (ninbin(ii)==0) then + meanzii = 0. + else + meanzii = sum(zsetgas(1:ninbin(ii),ii))/real(ninbin(ii)) + endif + H(ii) = sqrt(sum(((zsetgas(1:ninbin(ii),ii)-meanzii)**2)/(real(ninbin(ii)-1)))) + enddo + +end subroutine calculate_H + !-------------------------------------------------------- !+ ! Deallocate arrays @@ -628,6 +673,7 @@ subroutine deallocate_arrays deallocate(gr,gphi,Br,Bphi,vrbin,vphibin) deallocate(sigma,csbin,H,toomre_q,omega,epicyc) deallocate(alpha_reyn,alpha_grav,alpha_mag,alpha_art) + deallocate(part_scaleheight) end subroutine deallocate_arrays !------------------------------------------------------- From ae14e6761eb706af56610d5cbf02967716ef369c Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Thu, 16 May 2024 11:42:57 +0200 Subject: [PATCH 025/134] (CE-analysis) mistake---rad array should be used where radprop used --- src/main/ionization.f90 | 6 ++-- src/utils/analysis_common_envelope.f90 | 46 +++++++++++++------------- 2 files changed, 26 insertions(+), 26 deletions(-) diff --git a/src/main/ionization.f90 b/src/main/ionization.f90 index 2ebad8398..4823171f7 100644 --- a/src/main/ionization.f90 +++ b/src/main/ionization.f90 @@ -338,7 +338,7 @@ end subroutine get_erec_components ! gas particle. Inputs and outputs in code units !+ !---------------------------------------------------------------- -subroutine calc_thermal_energy(particlemass,ieos,xyzh,vxyzu,presi,tempi,ethi,radprop) +subroutine calc_thermal_energy(particlemass,ieos,xyzh,vxyzu,presi,tempi,ethi,rad) use dim, only:do_radiation use part, only:rhoh,iradxi use eos_idealplusrad, only:get_idealgasplusrad_tempfrompres,get_idealplusrad_enfromtemp @@ -346,7 +346,7 @@ subroutine calc_thermal_energy(particlemass,ieos,xyzh,vxyzu,presi,tempi,ethi,rad 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) - real, intent(in), optional :: radprop(:) + real, intent(in), optional :: rad(:) real, intent(out) :: ethi real :: hi,densi_cgs,mui @@ -359,7 +359,7 @@ subroutine calc_thermal_energy(particlemass,ieos,xyzh,vxyzu,presi,tempi,ethi,rad ethi = particlemass * ethi / unit_ergg case default ! assuming internal energy = thermal energy ethi = particlemass * vxyzu(4) - if (do_radiation) ethi = ethi + particlemass*radprop(iradxi) + if (do_radiation) ethi = ethi + particlemass*rad(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 a7ec86cff..f882e923a 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -22,7 +22,7 @@ module analysis use part, only:xyzmh_ptmass,vxyz_ptmass,nptmass,poten,ihsoft,ihacc,& rhoh,nsinkproperties,maxvxyzu,maxptmass,isdead_or_accreted,& - radprop + rad,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 @@ -521,7 +521,7 @@ end subroutine m_vs_t !+ !---------------------------------------------------------------- subroutine bound_mass(time,npart,particlemass,xyzh,vxyzu) - use part, only:eos_vars,itemp,radprop + use part, only:eos_vars,itemp use ptmass, only:get_accel_sink_gas use vectorutils, only:cross_product3D integer, intent(in) :: npart @@ -593,13 +593,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),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,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,ethi,radprop(:,i)) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,ethi,rad(:,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 @@ -755,7 +755,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),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) encomp(ipot_ps) = encomp(ipot_ps) + particlemass * phii @@ -1001,7 +1001,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),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,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)) @@ -1177,7 +1177,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),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,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 @@ -1417,7 +1417,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),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum1) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,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),ethi) quant(k,i) = (ekini + epoti + ethi) / particlemass ! Specific energy @@ -1828,7 +1828,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),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) ! Calculate total energy + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,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),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 @@ -1907,7 +1907,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),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,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),ethi) else @@ -2054,7 +2054,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),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) 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 @@ -2070,7 +2070,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),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,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) @@ -2202,7 +2202,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),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) 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))) @@ -2510,7 +2510,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),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,ethi) etoti = ekini + epoti + ethi @@ -2618,7 +2618,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),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,ethi) etoti = ekini + epoti + ethi @@ -2688,7 +2688,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),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) etoti = ekini + epoti + ethi @@ -2758,7 +2758,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),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) etoti = ekini + epoti + ethi @@ -3004,7 +3004,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),radprop(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) rhopart = rhoh(xyzh(4,i), particlemass) @@ -3350,7 +3350,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),radprop(:,i),xyzmh_ptmass,dum1,dum2,dum3,dum4,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,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 @@ -3754,14 +3754,14 @@ end subroutine get_gas_omega ! and internal energy of a gas particle. !+ !---------------------------------------------------------------- -subroutine calc_gas_energies(particlemass,poten,xyzh,vxyzu,radprop,xyzmh_ptmass,phii,epoti,ekini,einti,etoti) +subroutine calc_gas_energies(particlemass,poten,xyzh,vxyzu,rad,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,iradxi real, intent(in) :: particlemass real(4), intent(in) :: poten - real, intent(in) :: xyzh(:),vxyzu(:),radprop(:) + real, intent(in) :: xyzh(:),vxyzu(:),rad(:) real, dimension(5,nptmass), intent(in) :: xyzmh_ptmass real, intent(out) :: phii,epoti,ekini,einti,etoti real :: fxi,fyi,fzi @@ -3773,7 +3773,7 @@ subroutine calc_gas_energies(particlemass,poten,xyzh,vxyzu,radprop,xyzmh_ptmass, 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) + if (do_radiation) einti = einti + particlemass * rad(iradxi) etoti = epoti + ekini + einti end subroutine calc_gas_energies @@ -3900,7 +3900,7 @@ 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),radprop(:,i),& + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,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 45bbf52406ecc498eb4371080d738599c1dac70f Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Thu, 16 May 2024 11:44:20 +0200 Subject: [PATCH 026/134] (CE-analysis) particle tracking for radiation quantities --- src/utils/analysis_common_envelope.f90 | 64 +++++++++++++++++--------- 1 file changed, 41 insertions(+), 23 deletions(-) diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index f882e923a..1c933a570 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -154,7 +154,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) case(19) ! Optical depth profile call tau_profile(time,num,npart,particlemass,xyzh) case(20) ! Particle tracker - call track_particle(time,particlemass,xyzh,vxyzu) + call track_particle(time,npart,particlemass,xyzh,vxyzu) case(21) ! Unbound ion fractions call unbound_ionfrac(time,npart,particlemass,xyzh,vxyzu) case(22) ! Optical depth at recombination @@ -1561,31 +1561,40 @@ end subroutine eos_surfaces ! Particle tracker: Paint the life of a particle !+ !---------------------------------------------------------------- -subroutine track_particle(time,particlemass,xyzh,vxyzu) - use part, only:eos_vars,itemp - use eos, only:entropy +subroutine track_particle(time,npart,particlemass,xyzh,vxyzu) + use part, only:itemp,iradxi,ilambda + use eos, only:entropy + use radiation_utils, only:Trad_from_rhoxi use mesa_microphysics, only:getvalue_mesa - use ionization_mod, only:ionisation_fraction + use ionization_mod, only:ionisation_fraction real, intent(in) :: time,particlemass + integer, intent(in) :: npart real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - integer, parameter :: nparttotrack=10,ncols=17 + integer, parameter :: nparttotrack=6,ncols=20 real :: r,v,rhopart,ponrhoi,Si,spsoundi,tempi,machi,xh0,xh1,xhe0,xhe1,xhe2,& - ekini,einti,epoti,ethi,etoti,dum,phii,pgas,mu + ekini,einti,epoti,ethi,eradi,etoti,dum,phii,pgas,mu,rho_cgs,Tradi,lambdai real, dimension(ncols) :: datatable character(len=17) :: filenames(nparttotrack),columns(ncols) integer :: i,k,partID(nparttotrack),ientropy,ierr - partID = (/ 1,2,3,4,5,6,7,8,9,10 /) + ! pid_orig is a map from current particle ID to original particle ID, if particles have been removed +! call initial_to_current_IDs(npart,pid_orig) + +! partID = (/ 1,2,3,4,5,6,7,8,9,10 /) + partID = (/ 359018, 1669237, 342811, 598910, 1690937, 285745 /) columns = (/ ' r',& ' v',& ' rho',& ' temp',& + ' Trad',& + ' lambda',& 'entropy',& 'spsound',& ' mach',& ' ekin',& ' epot',& ' eth',& + ' erad',& ' eint',& ' etot',& ' xHI',& @@ -1605,36 +1614,45 @@ subroutine track_particle(time,particlemass,xyzh,vxyzu) r = separation(xyzh(1:3,i),xyzmh_ptmass(1:3,1)) v = separation(vxyzu(1:3,i),vxyz_ptmass(1:3,1)) rhopart = rhoh(xyzh(4,i), particlemass) + rho_cgs = rhopart*unit_density call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) machi = v / spsoundi select case(ieos) case(2) - ientropy = 1 + if (do_radiation) then + ientropy = 2 + else + ientropy = 1 + endif case(10,12) ientropy = 2 case default ientropy = -1 end select - if (ieos==10) then - call getvalue_mesa(rhopart*unit_density,vxyzu(4,i)*unit_ergg,3,pgas,ierr) ! Get gas pressure - mu = rhopart*unit_density * Rg * eos_vars(itemp,i) / pgas + if (ieos==10) then ! get mu + call getvalue_mesa(rho_cgs,vxyzu(4,i)*unit_ergg,3,pgas,ierr) ! Get gas pressure + mu = rho_cgs * Rg * tempi / pgas else mu = gmw endif - ! MESA ENTROPY - Si = 0. - if (ieos==10) then - Si = entropy(rhopart*unit_density,ponrhoi*rhopart*unit_pressure,mu,3,vxyzu(4,i)*unit_ergg,ierr) + Tradi = 0. + lambdai = 0. + if (do_radiation) then + lambdai = radprop(ilambda,i) + Tradi = Trad_from_rhoxi(rhopart,rad(iradxi,i)) + Si = entropy(rho_cgs,ponrhoi*rhopart*unit_pressure,mu,ientropy,vxyzu(4,i)*unit_ergg,ierr,Trad_in=Tradi) + else + Si = entropy(rho_cgs,ponrhoi*rhopart*unit_pressure,mu,ientropy,vxyzu(4,i)*unit_ergg,ierr) 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),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),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) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,ethi,rad(:,i)) + etoti = ekini + epoti + ethi ! ethi includes radiation energy + eradi = particlemass*rad(iradxi,i) + call ionisation_fraction(rho_cgs,tempi,X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) ! Write file - datatable = (/ r,v,rhopart,eos_vars(itemp,i),Si,spsoundi,machi,ekini,epoti,ethi,einti,etoti,xh0,xh1,xhe0,xhe1,xhe2 /) + datatable = (/ r,v,rhopart,tempi,Tradi,lambdai,Si,spsoundi,machi,ekini,epoti,ethi,eradi,einti,etoti,& + xh0,xh1,xhe0,xhe1,xhe2 /) call write_time_file(trim(adjustl(filenames(k))),columns,time,datatable,ncols,dump_number) enddo From 0f691db9509b5612d0674fd37686dfd1d8fbfd2b Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Thu, 16 May 2024 11:46:17 +0200 Subject: [PATCH 027/134] (radiation) entropy function to retrieve radiation temperature for rad arrays --- src/main/eos.f90 | 31 +++++++++++++++++++------------ src/main/radiation_utils.f90 | 24 ++++++++++++------------ src/setup/set_star_utils.f90 | 4 ++-- src/tests/test_sedov.F90 | 2 +- 4 files changed, 34 insertions(+), 27 deletions(-) diff --git a/src/main/eos.f90 b/src/main/eos.f90 index be0410681..67a791772 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -907,36 +907,43 @@ end subroutine calc_rho_from_PT ! up to an additive integration constant, from density and pressure. !+ !----------------------------------------------------------------------- -function entropy(rho,pres,mu_in,ientropy,eint_in,ierr) +function entropy(rho,pres,mu_in,ientropy,eint_in,ierr,T_in,Trad_in) use io, only:fatal,warning - use physcon, only:radconst,kb_on_mh + use physcon, only:radconst,kb_on_mh,Rg use eos_idealplusrad, only:get_idealgasplusrad_tempfrompres use eos_mesa, only:get_eos_eT_from_rhop_mesa use mesa_microphysics, only:getvalue_mesa real, intent(in) :: rho,pres,mu_in - real, intent(in), optional :: eint_in + real, intent(in), optional :: eint_in,T_in,Trad_in integer, intent(in) :: ientropy integer, intent(out), optional :: ierr - real :: mu,entropy,logentropy,temp,eint + real :: mu,entropy,logentropy,temp,Trad,eint if (present(ierr)) ierr=0 mu = mu_in - select case(ientropy) - case(1) ! Include only gas entropy (up to additive constants) - temp = pres * mu / (rho * kb_on_mh) - entropy = kb_on_mh / mu * log(temp**1.5/rho) + if (present(T_in)) then ! is gas temperature specified? + temp = T_in + else + temp = pres * mu / (rho * Rg) ! used as initial guess for case 2 + endif + select case(ientropy) + case(1) ! Only include gas contribution ! check temp if (temp < tiny(0.)) call warning('entropy','temperature = 0 will give minus infinity with s entropy') + entropy = kb_on_mh / mu * log(temp**1.5/rho) - case(2) ! Include both gas and radiation entropy (up to additive constants) - temp = pres * mu / (rho * kb_on_mh) ! Guess for temp + case(2) ! Include both gas and radiation contributions (up to additive constants) call get_idealgasplusrad_tempfrompres(pres,rho,mu,temp) ! First solve for temp from rho and pres - entropy = kb_on_mh / mu * log(temp**1.5/rho) + 4.*radconst*temp**3 / (3.*rho) - + if (present(Trad_in)) then + Trad = Trad_in + else + Trad = temp ! assume thermal equilibrium + endif ! check temp if (temp < tiny(0.)) call warning('entropy','temperature = 0 will give minus infinity with s entropy') + entropy = kb_on_mh / mu * log(temp**1.5/rho) + 4.*radconst*Trad**3 / (3.*rho) case(3) ! Get entropy from MESA tables if using MESA EoS if (ieos /= 10 .and. ieos /= 20) call fatal('eos','Using MESA tables to calculate S from rho and pres, but not using MESA EoS') diff --git a/src/main/radiation_utils.f90 b/src/main/radiation_utils.f90 index 0147e01c7..bb42061ea 100644 --- a/src/main/radiation_utils.f90 +++ b/src/main/radiation_utils.f90 @@ -23,8 +23,8 @@ module radiation_utils public :: get_rad_R public :: radiation_equation_of_state public :: T_from_Etot - public :: radE_from_Trad - public :: Trad_from_radE + public :: radxi_from_rhoT + public :: Trad_from_rhoxi public :: ugas_from_Tgas public :: Tgas_from_ugas public :: get_opacity @@ -136,29 +136,29 @@ end function T_from_Etot !--------------------------------------------------------- !+ -! get the radiation energy from the radiation temperature +! get specific radiation energy density from the radiation temperature !+ !--------------------------------------------------------- -real function radE_from_Trad(Trad) result(radE) +real function radxi_from_rhoT(rho,Trad) result(radxi) use units, only:get_radconst_code - real, intent(in) :: Trad + real, intent(in) :: Trad,rho - radE = Trad**4*get_radconst_code() + radxi = Trad**4*get_radconst_code()/rho -end function radE_from_Trad +end function radxi_from_rhoT !--------------------------------------------------------- !+ -! get the radiation temperature from the radiation energy per unit volume +! get the radiation temperature from specific radiation energy !+ !--------------------------------------------------------- -real function Trad_from_radE(radE) result(Trad) +real function Trad_from_rhoxi(rho,radxi) result(Trad) use units, only:get_radconst_code - real, intent(in) :: radE + real, intent(in) :: rho,radxi - Trad = (radE/get_radconst_code())**0.25 + Trad = (rho*radxi/get_radconst_code())**0.25 -end function Trad_from_radE +end function Trad_from_rhoxi !--------------------------------------------------------- !+ diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index 73a5d7017..bcdc754d6 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -382,7 +382,7 @@ subroutine set_star_thermalenergy(ieos,den,pres,r,npts,npart,xyzh,vxyzu,rad,eos_ relaxed,use_var_comp,initialtemp,npin) use part, only:do_radiation,rhoh,massoftype,igas,itemp,igasP,iX,iZ,imu,iradxi use eos, only:equationofstate,calc_temp_and_ene,gamma,gmw - use radiation_utils, only:ugas_from_Tgas,radE_from_Trad + use radiation_utils, only:ugas_from_Tgas,radxi_from_rhoT use table_utils, only:yinterp use units, only:unit_density,unit_ergg,unit_pressure integer, intent(in) :: ieos,npart,npts @@ -439,7 +439,7 @@ subroutine set_star_thermalenergy(ieos,den,pres,r,npts,npart,xyzh,vxyzu,rad,eos_ endif if (do_radiation) then vxyzu(4,i) = ugas_from_Tgas(tempi,gamma,gmw) - rad(iradxi,i) = radE_from_Trad(tempi)/densi + rad(iradxi,i) = radxi_from_rhoT(densi,tempi) else vxyzu(4,i) = eni / unit_ergg endif diff --git a/src/tests/test_sedov.F90 b/src/tests/test_sedov.F90 index d12efb34a..9e96630d7 100644 --- a/src/tests/test_sedov.F90 +++ b/src/tests/test_sedov.F90 @@ -54,7 +54,7 @@ subroutine test_sedov(ntests,npass) use mpidomain, only:i_belong use checkconserved, only:etot_in,angtot_in,totmom_in,mdust_in use radiation_utils, only:set_radiation_and_gas_temperature_equal,& - T_from_Etot,Tgas_from_ugas,ugas_from_Tgas,radE_from_Trad,Trad_from_radE + T_from_Etot,Tgas_from_ugas,ugas_from_Tgas use readwrite_dumps, only:write_fulldump use step_lf_global, only:init_step integer, intent(inout) :: ntests,npass From d857b4dd867235d5fa25e9e5a7294f9d62ddbe31 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Thu, 16 May 2024 14:32:50 +0200 Subject: [PATCH 028/134] (CE-analysis) revert changes to radE subroutines and correct radiation energy calculation --- src/main/ionization.f90 | 13 +++++++------ src/main/radiation_utils.f90 | 25 ++++++++++++------------- src/setup/set_star_utils.f90 | 4 ++-- src/utils/analysis_common_envelope.f90 | 13 ++++++++----- 4 files changed, 29 insertions(+), 26 deletions(-) diff --git a/src/main/ionization.f90 b/src/main/ionization.f90 index 4823171f7..d43c2fd10 100644 --- a/src/main/ionization.f90 +++ b/src/main/ionization.f90 @@ -348,18 +348,19 @@ subroutine calc_thermal_energy(particlemass,ieos,xyzh,vxyzu,presi,tempi,ethi,rad real, intent(in) :: particlemass,presi,tempi,xyzh(4),vxyzu(4) real, intent(in), optional :: rad(:) real, intent(out) :: ethi - real :: hi,densi_cgs,mui + real :: hi,densi_cgs,mui,rhoi + rhoi = rhoh(hi,particlemass) select case (ieos) case(10,20) ! calculate just gas + radiation thermal energy hi = xyzh(4) - densi_cgs = rhoh(hi,particlemass)*unit_density + densi_cgs = rhoi*unit_density mui = densi_cgs * Rg * tempi / (presi*unit_pressure - radconst * tempi**4 / 3.) ! Get mu from pres and temp call get_idealplusrad_enfromtemp(densi_cgs,tempi,mui,ethi) ethi = particlemass * ethi / unit_ergg case default ! assuming internal energy = thermal energy ethi = particlemass * vxyzu(4) - if (do_radiation) ethi = ethi + particlemass*rad(iradxi) + if (do_radiation) ethi = ethi + particlemass*rad(iradxi)/rhoi end select end subroutine calc_thermal_energy @@ -419,9 +420,9 @@ subroutine ionisation_fraction(dens,temp,X,Y,xh0,xh1,xhe0,xhe1,xhe2) xhe2g = xhe2g + dx(3) enddo - xh1 = xh1g * n / nh - xhe1 = xhe1g * n / nhe - xhe2 = xhe2g * n / nhe + xh1 = max(xh1g * n / nh,1.e-99) + xhe1 = max(xhe1g * n / nhe,1.e-99) + xhe2 = max(xhe2g * n / nhe,1.e-99) xh0 = ((nh/n) - xh1g) * n / nh xhe0 = ((nhe/n) - xhe1g - xhe2g) * n / nhe diff --git a/src/main/radiation_utils.f90 b/src/main/radiation_utils.f90 index bb42061ea..d54015bd6 100644 --- a/src/main/radiation_utils.f90 +++ b/src/main/radiation_utils.f90 @@ -23,8 +23,8 @@ module radiation_utils public :: get_rad_R public :: radiation_equation_of_state public :: T_from_Etot - public :: radxi_from_rhoT - public :: Trad_from_rhoxi + public :: radE_from_Trad + public :: Trad_from_radE public :: ugas_from_Tgas public :: Tgas_from_ugas public :: get_opacity @@ -136,29 +136,28 @@ end function T_from_Etot !--------------------------------------------------------- !+ -! get specific radiation energy density from the radiation temperature +! get the radiation energy from the radiation temperature !+ !--------------------------------------------------------- -real function radxi_from_rhoT(rho,Trad) result(radxi) +real function radE_from_Trad(Trad) result(radE) use units, only:get_radconst_code - real, intent(in) :: Trad,rho + real, intent(in) :: Trad - radxi = Trad**4*get_radconst_code()/rho + radE = Trad**4*get_radconst_code() -end function radxi_from_rhoT +end function radE_from_Trad !--------------------------------------------------------- !+ -! get the radiation temperature from specific radiation energy -!+ +! get the radiation temperature from the radiation energy per unit volume!+ !--------------------------------------------------------- -real function Trad_from_rhoxi(rho,radxi) result(Trad) +real function Trad_from_radE(radE) result(Trad) use units, only:get_radconst_code - real, intent(in) :: rho,radxi + real, intent(in) :: radE - Trad = (rho*radxi/get_radconst_code())**0.25 + Trad = (radE/get_radconst_code())**0.25 -end function Trad_from_rhoxi +end function Trad_from_radE !--------------------------------------------------------- !+ diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index bcdc754d6..73a5d7017 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -382,7 +382,7 @@ subroutine set_star_thermalenergy(ieos,den,pres,r,npts,npart,xyzh,vxyzu,rad,eos_ relaxed,use_var_comp,initialtemp,npin) use part, only:do_radiation,rhoh,massoftype,igas,itemp,igasP,iX,iZ,imu,iradxi use eos, only:equationofstate,calc_temp_and_ene,gamma,gmw - use radiation_utils, only:ugas_from_Tgas,radxi_from_rhoT + use radiation_utils, only:ugas_from_Tgas,radE_from_Trad use table_utils, only:yinterp use units, only:unit_density,unit_ergg,unit_pressure integer, intent(in) :: ieos,npart,npts @@ -439,7 +439,7 @@ subroutine set_star_thermalenergy(ieos,den,pres,r,npts,npart,xyzh,vxyzu,rad,eos_ endif if (do_radiation) then vxyzu(4,i) = ugas_from_Tgas(tempi,gamma,gmw) - rad(iradxi,i) = radxi_from_rhoT(densi,tempi) + rad(iradxi,i) = radE_from_Trad(tempi)/densi else vxyzu(4,i) = eni / unit_ergg endif diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 1c933a570..77567ead8 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -1564,7 +1564,7 @@ end subroutine eos_surfaces subroutine track_particle(time,npart,particlemass,xyzh,vxyzu) use part, only:itemp,iradxi,ilambda use eos, only:entropy - use radiation_utils, only:Trad_from_rhoxi + use radiation_utils, only:Trad_from_radE use mesa_microphysics, only:getvalue_mesa use ionization_mod, only:ionisation_fraction real, intent(in) :: time,particlemass @@ -1639,7 +1639,7 @@ subroutine track_particle(time,npart,particlemass,xyzh,vxyzu) lambdai = 0. if (do_radiation) then lambdai = radprop(ilambda,i) - Tradi = Trad_from_rhoxi(rhopart,rad(iradxi,i)) + Tradi = Trad_from_radE(rad(iradxi,i)) Si = entropy(rho_cgs,ponrhoi*rhopart*unit_pressure,mu,ientropy,vxyzu(4,i)*unit_ergg,ierr,Trad_in=Tradi) else Si = entropy(rho_cgs,ponrhoi*rhopart*unit_pressure,mu,ientropy,vxyzu(4,i)*unit_ergg,ierr) @@ -1647,7 +1647,7 @@ subroutine track_particle(time,npart,particlemass,xyzh,vxyzu) call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,ethi,rad(:,i)) etoti = ekini + epoti + ethi ! ethi includes radiation energy - eradi = particlemass*rad(iradxi,i) + eradi = particlemass*rad(iradxi,i)/rhopart call ionisation_fraction(rho_cgs,tempi,X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) ! Write file @@ -3782,7 +3782,7 @@ subroutine calc_gas_energies(particlemass,poten,xyzh,vxyzu,rad,xyzmh_ptmass,phii real, intent(in) :: xyzh(:),vxyzu(:),rad(:) real, dimension(5,nptmass), intent(in) :: xyzmh_ptmass real, intent(out) :: phii,epoti,ekini,einti,etoti - real :: fxi,fyi,fzi + real :: fxi,fyi,fzi,rhopart phii = 0.0 @@ -3791,7 +3791,10 @@ subroutine calc_gas_energies(particlemass,poten,xyzh,vxyzu,rad,xyzmh_ptmass,phii 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 * rad(iradxi) + if (do_radiation) then + rhopart = rhoh(xyzh(4),particlemass) + einti = einti + particlemass * rad(iradxi)/rhopart + endif etoti = epoti + ekini + einti end subroutine calc_gas_energies From e2631612975f439049a79de31a002830ce3041e1 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Wed, 22 May 2024 19:37:04 +0200 Subject: [PATCH 029/134] (eos_idealplusrad) add functions to calculate egas and erad separately --- src/main/eos_idealplusrad.f90 | 30 ++++++++++++++++++++++++++++-- 1 file changed, 28 insertions(+), 2 deletions(-) diff --git a/src/main/eos_idealplusrad.f90 b/src/main/eos_idealplusrad.f90 index e2a6c10aa..df37e4902 100644 --- a/src/main/eos_idealplusrad.f90 +++ b/src/main/eos_idealplusrad.f90 @@ -24,7 +24,7 @@ module eos_idealplusrad public :: get_idealplusrad_temp,get_idealplusrad_pres,get_idealplusrad_spsoundi,& get_idealgasplusrad_tempfrompres,get_idealplusrad_enfromtemp,& - get_idealplusrad_rhofrompresT + get_idealplusrad_rhofrompresT,egas_from_rhoT,erad_from_rhoT private @@ -125,11 +125,37 @@ subroutine get_idealplusrad_enfromtemp(densi,tempi,mu,eni) real, intent(in) :: densi,tempi,mu real, intent(out) :: eni - eni = 1.5*Rg*tempi/mu + radconst*tempi**4/densi + eni = egas_from_rhoT(densi,tempi,mu) + erad_from_rhoT(densi,tempi,mu) end subroutine get_idealplusrad_enfromtemp +!---------------------------------------------------------------- +!+ +! Calculates specific gas energy from density and temperature +!+ +!---------------------------------------------------------------- +real function egas_from_rhoT(densi,tempi,mu) result(egasi) + real, intent(in) :: densi,tempi,mu + + egasi = 1.5*Rg*tempi/mu + +end function egas_from_rhoT + + +!---------------------------------------------------------------- +!+ +! Calculates specific radiation energy from density and temperature +!+ +!---------------------------------------------------------------- +real function erad_from_rhoT(densi,tempi,mu) result(eradi) + real, intent(in) :: densi,tempi,mu + + eradi = radconst*tempi**4/densi + +end function erad_from_rhoT + + !---------------------------------------------------------------- !+ ! Calculates density from pressure and temperature From d44b98184a3b3d48bf8f0741c71f4d569afbd72a Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Thu, 23 May 2024 15:42:10 +0200 Subject: [PATCH 030/134] big fixes for radiation utility functions --- src/main/eos.f90 | 6 ++++-- src/main/ionization.f90 | 8 +++----- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/main/eos.f90 b/src/main/eos.f90 index 67a791772..af2cf2f8a 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -935,11 +935,13 @@ function entropy(rho,pres,mu_in,ientropy,eint_in,ierr,T_in,Trad_in) entropy = kb_on_mh / mu * log(temp**1.5/rho) case(2) ! Include both gas and radiation contributions (up to additive constants) - call get_idealgasplusrad_tempfrompres(pres,rho,mu,temp) ! First solve for temp from rho and pres if (present(Trad_in)) then Trad = Trad_in else - Trad = temp ! assume thermal equilibrium + if (.not. present(T_in)) then + call get_idealgasplusrad_tempfrompres(pres,rho,mu,temp) ! First solve for temp from rho and pres + Trad = temp ! assume thermal equilibrium + endif endif ! check temp if (temp < tiny(0.)) call warning('entropy','temperature = 0 will give minus infinity with s entropy') diff --git a/src/main/ionization.f90 b/src/main/ionization.f90 index d43c2fd10..103d19020 100644 --- a/src/main/ionization.f90 +++ b/src/main/ionization.f90 @@ -348,19 +348,17 @@ subroutine calc_thermal_energy(particlemass,ieos,xyzh,vxyzu,presi,tempi,ethi,rad real, intent(in) :: particlemass,presi,tempi,xyzh(4),vxyzu(4) real, intent(in), optional :: rad(:) real, intent(out) :: ethi - real :: hi,densi_cgs,mui,rhoi + real :: densi_cgs,mui - rhoi = rhoh(hi,particlemass) select case (ieos) case(10,20) ! calculate just gas + radiation thermal energy - hi = xyzh(4) - densi_cgs = rhoi*unit_density + densi_cgs = rhoh(xyzh(4),particlemass)*unit_density mui = densi_cgs * Rg * tempi / (presi*unit_pressure - radconst * tempi**4 / 3.) ! Get mu from pres and temp call get_idealplusrad_enfromtemp(densi_cgs,tempi,mui,ethi) ethi = particlemass * ethi / unit_ergg case default ! assuming internal energy = thermal energy ethi = particlemass * vxyzu(4) - if (do_radiation) ethi = ethi + particlemass*rad(iradxi)/rhoi + if (do_radiation) ethi = ethi + particlemass*rad(iradxi) end select end subroutine calc_thermal_energy From d76ed843d7c4798e9f010e30e5f2b24a2361ec9f Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Thu, 23 May 2024 15:43:00 +0200 Subject: [PATCH 031/134] revert Trad and E conversion functions back to Trad and xi --- src/main/radiation_utils.f90 | 25 +++++++++++++------------ src/setup/set_star_utils.f90 | 4 ++-- 2 files changed, 15 insertions(+), 14 deletions(-) diff --git a/src/main/radiation_utils.f90 b/src/main/radiation_utils.f90 index d54015bd6..19b176db9 100644 --- a/src/main/radiation_utils.f90 +++ b/src/main/radiation_utils.f90 @@ -23,8 +23,8 @@ module radiation_utils public :: get_rad_R public :: radiation_equation_of_state public :: T_from_Etot - public :: radE_from_Trad - public :: Trad_from_radE + public :: radxi_from_Trad + public :: Trad_from_radxi public :: ugas_from_Tgas public :: Tgas_from_ugas public :: get_opacity @@ -136,28 +136,29 @@ end function T_from_Etot !--------------------------------------------------------- !+ -! get the radiation energy from the radiation temperature +! get specific radiation energy from radiation temperature !+ !--------------------------------------------------------- -real function radE_from_Trad(Trad) result(radE) +real function radxi_from_Trad(rho,Trad) result(radxi) use units, only:get_radconst_code - real, intent(in) :: Trad + real, intent(in) :: rho,Trad - radE = Trad**4*get_radconst_code() + radxi = Trad**4*get_radconst_code()/rho -end function radE_from_Trad +end function radxi_from_Trad !--------------------------------------------------------- !+ -! get the radiation temperature from the radiation energy per unit volume!+ +! get radiation temperature from the specific radiation energy +!+ !--------------------------------------------------------- -real function Trad_from_radE(radE) result(Trad) +real function Trad_from_radxi(rho,radxi) result(Trad) use units, only:get_radconst_code - real, intent(in) :: radE + real, intent(in) :: rho,radxi - Trad = (radE/get_radconst_code())**0.25 + Trad = (rho*radxi/get_radconst_code())**0.25 -end function Trad_from_radE +end function Trad_from_radxi !--------------------------------------------------------- !+ diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index 73a5d7017..12942d71a 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -382,7 +382,7 @@ subroutine set_star_thermalenergy(ieos,den,pres,r,npts,npart,xyzh,vxyzu,rad,eos_ relaxed,use_var_comp,initialtemp,npin) use part, only:do_radiation,rhoh,massoftype,igas,itemp,igasP,iX,iZ,imu,iradxi use eos, only:equationofstate,calc_temp_and_ene,gamma,gmw - use radiation_utils, only:ugas_from_Tgas,radE_from_Trad + use radiation_utils, only:ugas_from_Tgas,radxi_from_Trad use table_utils, only:yinterp use units, only:unit_density,unit_ergg,unit_pressure integer, intent(in) :: ieos,npart,npts @@ -439,7 +439,7 @@ subroutine set_star_thermalenergy(ieos,den,pres,r,npts,npart,xyzh,vxyzu,rad,eos_ endif if (do_radiation) then vxyzu(4,i) = ugas_from_Tgas(tempi,gamma,gmw) - rad(iradxi,i) = radE_from_Trad(tempi)/densi + rad(iradxi,i) = radxi_from_Trad(tempi) else vxyzu(4,i) = eni / unit_ergg endif From a86125cec4ce6b10a8d30f234a048a4c61c4ba60 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Thu, 23 May 2024 15:45:03 +0200 Subject: [PATCH 032/134] (CE-analysis) calc_gas_energies to output gas thermal and radiation energies --- src/utils/analysis_common_envelope.f90 | 161 +++++++++++++++---------- 1 file changed, 97 insertions(+), 64 deletions(-) diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 77567ead8..ae2d46ad4 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -527,7 +527,7 @@ subroutine bound_mass(time,npart,particlemass,xyzh,vxyzu) integer, intent(in) :: npart real, intent(in) :: time,particlemass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - real :: etoti,ekini,epoti,phii,einti,ethi + real :: etoti,ekini,epoti,phii,ereci,egasi,eradi,ethi real :: E_H2,E_HI,E_HeI,E_HeII real, save :: Xfrac,Yfrac,Zfrac real :: rhopart,ponrhoi,spsoundi,tempi,dum1,dum2,dum3 @@ -593,7 +593,8 @@ 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),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,& + egasi,eradi,ereci,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) @@ -606,7 +607,6 @@ subroutine bound_mass(time,npart,particlemass,xyzh,vxyzu) etoti = 0. epoti = 0. ekini = 0. - einti = 0. ethi = 0. phii = 0. ponrhoi = 0. @@ -686,7 +686,7 @@ subroutine calculate_energies(time,npart,particlemass,xyzh,vxyzu) integer, intent(in) :: npart real, intent(in) :: time,particlemass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - real :: etoti,ekini,einti,epoti,phii,phii1,jz,fxi,fyi,fzi + real :: etoti,ekini,egasi,eradi,ereci,epoti,phii,phii1,jz,fxi,fyi,fzi real :: rhopart,ponrhoi,spsoundi,tempi,r_ij,radvel real, dimension(3) :: rcrossmv character(len=17), allocatable :: columns(:) @@ -755,7 +755,8 @@ 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),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,& + epoti,ekini,egasi,eradi,ereci,etoti) encomp(ipot_ps) = encomp(ipot_ps) + particlemass * phii @@ -927,7 +928,7 @@ subroutine roche_lobe_values(time,npart,particlemass,xyzh,vxyzu) integer, parameter :: iFBV = 20 integer, parameter :: iFBJz = 21 real, dimension(iFBJz) :: MRL - real :: etoti, ekini, einti, epoti, phii, jz + real :: etoti, ekini, ereci, egasi, eradi, epoti, phii, jz logical, dimension(:), allocatable, save:: transferred real, save :: m1, m2 real :: sep, sep1, sep2 @@ -1001,7 +1002,8 @@ 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),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,& + epoti,ekini,egasi,eradi,ereci,etoti) sep1 = separation(xyzmh_ptmass(1:3,1),xyzh(1:3,i)) sep2 = separation(xyzmh_ptmass(1:3,2),xyzh(1:3,i)) @@ -1132,7 +1134,8 @@ subroutine star_stabilisation_suite(time,npart,particlemass,xyzh,vxyzu) integer, allocatable :: iorder(:),iorder_a(:) real, allocatable :: star_stability(:) real :: total_mass,rhovol,totvol,rhopart,virialpart,virialfluid - real :: phii,ponrhoi,spsoundi,tempi,epoti,ekini,einti,etoti,totekin,totepot,virialintegral,gamma + real :: phii,ponrhoi,spsoundi,tempi,epoti,ekini,egasi,eradi,ereci,etoti + real :: totekin,totepot,virialintegral,gamma integer, parameter :: ivoleqrad = 1 integer, parameter :: idensrad = 2 integer, parameter :: imassout = 3 @@ -1177,7 +1180,8 @@ 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),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,& + epoti,ekini,egasi,eradi,ereci,etoti) totekin = totekin + ekini totepot = totepot + 0.5*epoti ! Factor of 1/2 to correct for double counting if (rhopart > rho_surface) then @@ -1289,7 +1293,7 @@ subroutine output_divv_files(time,dumpfile,npart,particlemass,xyzh,vxyzu) integer :: i,k,Nquantities,ierr,iu integer, save :: quantities_to_calculate(4) integer, allocatable :: iorder(:) - real :: ekini,einti,epoti,ethi,phii,rho_cgs,ponrhoi,spsoundi,tempi,& + real :: ekini,epoti,egasi,eradi,ereci,ethi,phii,rho_cgs,ponrhoi,spsoundi,tempi,& omega_orb,kappai,kappat,kappar,pgas,mu,entropyi,rhopart,& dum1,dum2,dum3,dum4,dum5 real, allocatable, save :: init_entropy(:) @@ -1417,7 +1421,8 @@ 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),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum1) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,& + epoti,ekini,egasi,eradi,ereci,dum1) if (quantities_to_calculate(k)==1) then call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) quant(k,i) = (ekini + epoti + ethi) / particlemass ! Specific energy @@ -1564,7 +1569,7 @@ end subroutine eos_surfaces subroutine track_particle(time,npart,particlemass,xyzh,vxyzu) use part, only:itemp,iradxi,ilambda use eos, only:entropy - use radiation_utils, only:Trad_from_radE + use radiation_utils, only:Trad_from_radxi use mesa_microphysics, only:getvalue_mesa use ionization_mod, only:ionisation_fraction real, intent(in) :: time,particlemass @@ -1572,7 +1577,7 @@ subroutine track_particle(time,npart,particlemass,xyzh,vxyzu) real, intent(inout) :: xyzh(:,:),vxyzu(:,:) integer, parameter :: nparttotrack=6,ncols=20 real :: r,v,rhopart,ponrhoi,Si,spsoundi,tempi,machi,xh0,xh1,xhe0,xhe1,xhe2,& - ekini,einti,epoti,ethi,eradi,etoti,dum,phii,pgas,mu,rho_cgs,Tradi,lambdai + ekini,egasi,eradi,epoti,ereci,etoti,phii,pgas,mu,rho_cgs,Tradi,lambdai real, dimension(ncols) :: datatable character(len=17) :: filenames(nparttotrack),columns(ncols) integer :: i,k,partID(nparttotrack),ientropy,ierr @@ -1581,7 +1586,7 @@ subroutine track_particle(time,npart,particlemass,xyzh,vxyzu) ! call initial_to_current_IDs(npart,pid_orig) ! partID = (/ 1,2,3,4,5,6,7,8,9,10 /) - partID = (/ 359018, 1669237, 342811, 598910, 1690937, 285745 /) + partID = (/ 193332, 966126, 1303771, 1466288, 142011, 36840 /) columns = (/ ' r',& ' v',& ' rho',& @@ -1593,9 +1598,9 @@ subroutine track_particle(time,npart,particlemass,xyzh,vxyzu) ' mach',& ' ekin',& ' epot',& - ' eth',& + ' egas',& ' erad',& - ' eint',& + ' erec',& ' etot',& ' xHI',& ' xHII',& @@ -1639,19 +1644,17 @@ subroutine track_particle(time,npart,particlemass,xyzh,vxyzu) lambdai = 0. if (do_radiation) then lambdai = radprop(ilambda,i) - Tradi = Trad_from_radE(rad(iradxi,i)) + Tradi = Trad_from_radxi(rhopart,rad(iradxi,i)) Si = entropy(rho_cgs,ponrhoi*rhopart*unit_pressure,mu,ientropy,vxyzu(4,i)*unit_ergg,ierr,Trad_in=Tradi) else Si = entropy(rho_cgs,ponrhoi*rhopart*unit_pressure,mu,ientropy,vxyzu(4,i)*unit_ergg,ierr) endif - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,ethi,rad(:,i)) - etoti = ekini + epoti + ethi ! ethi includes radiation energy - eradi = particlemass*rad(iradxi,i)/rhopart + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,& + epoti,ekini,egasi,eradi,ereci,etoti) call ionisation_fraction(rho_cgs,tempi,X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) ! Write file - datatable = (/ r,v,rhopart,tempi,Tradi,lambdai,Si,spsoundi,machi,ekini,epoti,ethi,eradi,einti,etoti,& + datatable = (/ r,v,rhopart,tempi,Tradi,lambdai,Si,spsoundi,machi,ekini,epoti,egasi,eradi,ereci,etoti,& xh0,xh1,xhe0,xhe1,xhe2 /) call write_time_file(trim(adjustl(filenames(k))),columns,time,datatable,ncols,dump_number) enddo @@ -1819,7 +1822,7 @@ subroutine recombination_tau(time,npart,particlemass,xyzh,vxyzu) real, allocatable :: kappa_hist(:),rho_hist(:),tau_r(:),sepbins(:),sepbins_cm(:) logical, allocatable, save :: prev_recombined(:) real :: maxloga,minloga,kappa,kappat,kappar,xh0,xh1,xhe0,xhe1,xhe2,& - ponrhoi,spsoundi,tempi,etoti,ekini,einti,epoti,ethi,phii,dum + ponrhoi,spsoundi,tempi,etoti,ekini,ereci,egasi,eradi,epoti,ethi,phii,dum real, parameter :: recomb_th=0.9 integer :: i,j,nrecombined,bin_ind @@ -1846,7 +1849,8 @@ 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),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) ! Calculate total energy + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,& + epoti,ekini,egasi,eradi,ereci,dum) 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 @@ -1906,7 +1910,7 @@ subroutine energy_hist(time,npart,particlemass,xyzh,vxyzu) character(len=40) :: data_formatter integer :: nbins,nhists,i,unitnum real, allocatable :: hist(:),coord(:,:),Emin(:),Emax(:) - real :: rhopart,ponrhoi,spsoundi,tempi,phii,epoti,ekini,einti,ethi,dum + real :: rhopart,ponrhoi,spsoundi,tempi,phii,epoti,ekini,ereci,egasi,eradi,ethi,dum real, allocatable :: quant(:) logical :: ilogbins @@ -1925,11 +1929,12 @@ 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),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,& + epoti,ekini,egasi,eradi,ereci,dum) if (ieos==10 .or. ieos==20) then call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) else - ethi = einti + ethi = ethi+ereci endif coord(i,1) = (ekini + epoti)/particlemass coord(i,2) = vxyzu(4,i) - ethi/particlemass @@ -1970,7 +1975,7 @@ subroutine energy_profile(time,npart,particlemass,xyzh,vxyzu) integer :: nbins real, allocatable :: coord(:) real, allocatable :: hist(:),quant(:,:) - real :: ekini,einti,epoti,ethi,phii,pgas,mu,dum,rhopart,ponrhoi,spsoundi,tempi,& + real :: ekini,ereci,egasi,eradi,epoti,ethi,phii,pgas,mu,dum,rhopart,ponrhoi,spsoundi,tempi,& maxcoord,mincoord,xh0,xh1,xhe0,xhe1,xhe2 character(len=17), allocatable :: filename(:),headerline(:) character(len=40) :: data_formatter @@ -2072,7 +2077,8 @@ 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),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,& + epoti,ekini,egasi,eradi,ereci,dum) 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 @@ -2088,7 +2094,8 @@ 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),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,& + epoti,ekini,egasi,eradi,ereci,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) @@ -2213,14 +2220,15 @@ subroutine velocity_histogram(time,num,npart,particlemass,xyzh,vxyzu) character(len=40) :: data_formatter character(len=40) :: file_name1,file_name2 integer :: i,iu1,iu2,ncols - real :: ponrhoi,rhopart,spsoundi,phii,epoti,ekini,einti,tempi,ethi,dum + real :: ponrhoi,rhopart,spsoundi,phii,epoti,ekini,ereci,egasi,eradi,tempi,ethi,dum real, allocatable :: vbound(:),vunbound(:),vr(:) allocate(vbound(npart),vunbound(npart),vr(npart)) 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),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,& + epoti,ekini,egasi,eradi,ereci,dum) 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))) @@ -2495,7 +2503,7 @@ subroutine unbound_profiles(time,num,npart,particlemass,xyzh,vxyzu) integer, dimension(4) :: npart_hist real, dimension(5,npart) :: dist_part,rad_part real, dimension(:), allocatable :: hist_var - real :: etoti,ekini,einti,epoti,ethi,phii,dum,rhopart,ponrhoi,spsoundi,tempi + real :: etoti,ekini,ereci,egasi,eradi,epoti,ethi,phii,dum,rhopart,ponrhoi,spsoundi,tempi real :: maxloga,minloga character(len=18), dimension(4) :: grid_file character(len=40) :: data_formatter @@ -2528,7 +2536,8 @@ 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),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,& + epoti,ekini,egasi,eradi,ereci,dum) call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,ethi) etoti = ekini + epoti + ethi @@ -2613,7 +2622,7 @@ subroutine unbound_ionfrac(time,npart,particlemass,xyzh,vxyzu) real, intent(inout) :: xyzh(:,:),vxyzu(:,:) character(len=17) :: columns(5) integer :: i - real :: etoti,ekini,einti,epoti,ethi,phii,dum,rhopart,xion(1:4),& + real :: etoti,ekini,egasi,eradi,ereci,epoti,ethi,phii,dum,rhopart,xion(1:4),& ponrhoi,spsoundi,tempi,xh0,xh1,xhe0,xhe1,xhe2 logical, allocatable, save :: prev_unbound(:),prev_bound(:) real, allocatable, save :: ionfrac(:,:) @@ -2636,7 +2645,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),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,egasi,eradi,ereci,dum) call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,ethi) etoti = ekini + epoti + ethi @@ -2689,7 +2698,7 @@ subroutine unbound_temp(time,npart,particlemass,xyzh,vxyzu) real, intent(inout) :: xyzh(:,:),vxyzu(:,:) character(len=17) :: columns(1) integer :: i,final_count(7) - real :: etoti,ekini,einti,epoti,ethi,phii,dum,rhopart,& + real :: etoti,ekini,ereci,egasi,eradi,epoti,ethi,phii,dum,rhopart,& ponrhoi,spsoundi,temp_bins(7) logical, allocatable, save :: prev_unbound(:),prev_bound(:) real, allocatable, save :: temp_unbound(:) @@ -2706,7 +2715,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),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,egasi,eradi,ereci,dum) call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) etoti = ekini + epoti + ethi @@ -2761,7 +2770,7 @@ subroutine recombination_stats(time,num,npart,particlemass,xyzh,vxyzu) integer, intent(in) :: npart,num real, intent(in) :: time,particlemass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - real :: etoti,ekini,einti,epoti,ethi,phii,dum,rhopart,& + real :: etoti,ekini,egasi,eradi,ereci,epoti,ethi,phii,dum,rhopart,& ponrhoi,spsoundi,tempi,pressure,temperature,xh0,xh1,xhe0,xhe1,xhe2 character(len=40) :: data_formatter,logical_format logical, allocatable :: isbound(:) @@ -2776,7 +2785,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),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,dum) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,egasi,eradi,ereci,dum) call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) etoti = ekini + epoti + ethi @@ -2999,7 +3008,7 @@ subroutine bound_unbound_thermo(time,npart,particlemass,xyzh,vxyzu) character(len=17), allocatable :: columns(:) integer :: i, ncols real, dimension(8) :: entropy_array - real :: etoti, ekini, einti, epoti, phii, rhopart + real :: etoti, ekini, epoti, phii, rhopart,egasi,eradi,ereci real :: pres_1, proint_1, peint_1, temp_1 real :: troint_1, teint_1, entrop_1, abad_1, gamma1_1, gam_1 integer, parameter :: ient_b = 1 @@ -3022,7 +3031,8 @@ 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),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,& + epoti,ekini,egasi,eradi,ereci,etoti) rhopart = rhoh(xyzh(4,i), particlemass) @@ -3034,7 +3044,7 @@ subroutine bound_unbound_thermo(time,npart,particlemass,xyzh,vxyzu) !sums entropy and other quantities for bound particles and unbound particles if (.not. switch(1)) then - etoti = etoti - einti + etoti = etoti - egasi - eradi - ereci endif if (etoti < 0.0) then !bound @@ -3352,7 +3362,7 @@ subroutine J_E_plane(num,npart,particlemass,xyzh,vxyzu) real, intent(in) :: particlemass,xyzh(:,:),vxyzu(:,:) character(len=17), allocatable :: columns(:) integer :: ncols,i - real :: com_xyz(3),com_vxyz(3),dum1,dum2,dum3,dum4,etoti,angmom_com(3),angmom_core(3) + real :: com_xyz(3),com_vxyz(3),dum1,dum2,dum3,dum4,dum5,dum6,etoti,angmom_com(3),angmom_core(3) real, allocatable :: data(:,:) ncols = 7 @@ -3368,7 +3378,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),rad(:,i),xyzmh_ptmass,dum1,dum2,dum3,dum4,etoti) + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,dum1,dum2,dum3,dum4,dum5,dum6,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 @@ -3769,33 +3779,58 @@ end subroutine get_gas_omega !---------------------------------------------------------------- !+ ! Calculate kinetic, gravitational potential (gas-gas and sink-gas), -! and internal energy of a gas particle. +! and other energies of a gas particle. !+ !---------------------------------------------------------------- -subroutine calc_gas_energies(particlemass,poten,xyzh,vxyzu,rad,xyzmh_ptmass,phii,epoti,ekini,einti,etoti) +subroutine calc_gas_energies(particlemass,poten,xyzh,vxyzu,rad,xyzmh_ptmass,phii,epoti,ekini,egasi,eradi,ereci,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,iradxi + use ptmass, only:get_accel_sink_gas + use part, only:nptmass,iradxi,itemp + use eos_idealplusrad, only:get_idealplusrad_temp,egas_from_rhoT,erad_from_rhoT real, intent(in) :: particlemass real(4), intent(in) :: poten real, intent(in) :: xyzh(:),vxyzu(:),rad(:) real, dimension(5,nptmass), intent(in) :: xyzmh_ptmass - real, intent(out) :: phii,epoti,ekini,einti,etoti - real :: fxi,fyi,fzi,rhopart - - phii = 0.0 + real, intent(out) :: phii,epoti,ekini,egasi,eradi,ereci,etoti + real :: fxi,fyi,fzi,rhoi,spsoundi,ponrhoi,presi,tempi,egasradi + integer :: ierr + rhoi = rhoh(xyzh(4),particlemass) + phii = 0. call get_accel_sink_gas(nptmass,xyzh(1),xyzh(2),xyzh(3),xyzh(4),xyzmh_ptmass,fxi,fyi,fzi,phii) - 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) + + egasi = 0. + ereci = 0. if (do_radiation) then - rhopart = rhoh(xyzh(4),particlemass) - einti = einti + particlemass * rad(iradxi)/rhopart + eradi = rad(iradxi)*particlemass + else + eradi = 0. endif - etoti = epoti + ekini + einti + + select case (ieos) + case(2) + egasi = vxyzu(4)*particlemass + egasradi = egasi + eradi + case(10) ! not tested + eradi = 0. ! not implemented + egasi = 0. ! not implemented + call equationofstate(ieos,ponrhoi,spsoundi,rhoi,xyzh(1),xyzh(2),xyzh(3),tempi,vxyzu(4)) + presi = ponrhoi*rhoi + call calc_thermal_energy(particlemass,10,xyzh,vxyzu,presi,tempi,egasradi,rad) + ereci = vxyzu(4)*particlemass - egasradi + case(12) + call get_idealplusrad_temp(rhoi,vxyzu(4)*unit_ergg,gmw,tempi,ierr) + egasi = egas_from_rhoT(rhoi,tempi,gmw)*particlemass + eradi = erad_from_rhoT(rhoi,tempi,gmw)*particlemass + egasradi = egasi + eradi + case default + call fatal('calc_gas_energies',"EOS type not supported (currently, only supporting ieos=2,10,12)") + end select + + etoti = epoti + ekini + ereci + egasradi end subroutine calc_gas_energies @@ -3869,7 +3904,7 @@ subroutine stellar_profile(time,ncols,particlemass,npart,xyzh,vxyzu,profile,simp real :: proj(3),orth(3),proj_mag,orth_dist,orth_ratio real :: rhopart,ponrhoi,spsoundi,tempi real :: temp,kappa,kappat,kappar,pres - real :: ekini,epoti,einti,etoti,phii + real :: ekini,epoti,egasi,eradi,ereci,etoti,phii real :: xh0, xh1, xhe0, xhe1, xhe2 real :: temp_profile(ncols,npart) logical :: criteria @@ -3922,7 +3957,7 @@ subroutine stellar_profile(time,ncols,particlemass,npart,xyzh,vxyzu,profile,simp endif call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),& - xyzmh_ptmass,phii,epoti,ekini,einti,etoti) + xyzmh_ptmass,phii,epoti,ekini,egasi,eradi,ereci,etoti) call ionisation_fraction(rhopart*unit_density,temp,X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) @@ -4466,10 +4501,8 @@ subroutine set_eos_options(analysis_to_perform) case(2,12) gamma = 5./3. call prompt('Enter gamma:',gamma,0.) - if (ieos==12) then - gmw = 0.618212823 - call prompt('Enter mean molecular weight for gas+rad EoS:',gmw,0.) - endif + gmw = 0.618212823 + call prompt('Enter mean molecular weight for gas+rad EoS:',gmw,0.) case(10,20) gamma = 5./3. X_in = 0.69843 From cfc2e49dc0f5e450df1c92754e42bda9eeaa6a91 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Fri, 7 Jun 2024 17:23:51 +0200 Subject: [PATCH 033/134] (CE-analysis) clean up unbound_profiles subroutine --- src/utils/analysis_common_envelope.f90 | 35 +++++++++++--------------- 1 file changed, 14 insertions(+), 21 deletions(-) diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index ae2d46ad4..cbaa2cf73 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -2497,18 +2497,17 @@ end subroutine planet_profile !+ !---------------------------------------------------------------- subroutine unbound_profiles(time,num,npart,particlemass,xyzh,vxyzu) - integer, intent(in) :: npart,num - real, intent(in) :: time,particlemass - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - integer, dimension(4) :: npart_hist - real, dimension(5,npart) :: dist_part,rad_part - real, dimension(:), allocatable :: hist_var - real :: etoti,ekini,ereci,egasi,eradi,epoti,ethi,phii,dum,rhopart,ponrhoi,spsoundi,tempi - real :: maxloga,minloga - character(len=18), dimension(4) :: grid_file - character(len=40) :: data_formatter - logical, allocatable, save :: prev_unbound(:,:),prev_bound(:,:) - integer :: i,unitnum,nbins + integer, intent(in) :: npart,num + real, intent(in) :: time,particlemass + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + integer, dimension(4) :: npart_hist + real, dimension(5,npart) :: dist_part,rad_part + real, dimension(:), allocatable :: hist_var + real :: etoti,ekini,ereci,egasi,eradi,epoti,phii,dum,maxloga,minloga + character(len=18), dimension(4) :: grid_file + character(len=40) :: data_formatter + logical, allocatable, save :: prev_unbound(:,:),prev_bound(:,:) + integer :: i,unitnum,nbins call compute_energies(time) npart_hist = 0 ! Stores number of particles fulfilling each of the four bound/unbound criterion @@ -2534,12 +2533,9 @@ subroutine unbound_profiles(time,num,npart,particlemass,xyzh,vxyzu) do i=1,npart 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),rad(:,i),xyzmh_ptmass,phii,& epoti,ekini,egasi,eradi,ereci,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,tempi,ethi) - etoti = ekini + epoti + ethi + etoti = ekini + epoti + egasi + eradi ! Ekin + Epot + Eth > 0 if ((etoti > 0.) .and. (.not. prev_unbound(1,i))) then @@ -2590,15 +2586,12 @@ subroutine unbound_profiles(time,num,npart,particlemass,xyzh,vxyzu) write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" ! Time column plus nbins columns if (num == 0) then ! Write header line - unitnum = 1000 - open(unit=unitnum,file=trim(adjustl(grid_file(i))),status='replace') + open(newunit=unitnum,file=trim(adjustl(grid_file(i))),status='replace') write(unitnum, "(a)") '# Newly bound/unbound particles' close(unit=unitnum) endif - unitnum=1001+i - - open(unit=unitnum,file=trim(adjustl(grid_file(i))), position='append') + open(newunit=unitnum,file=trim(adjustl(grid_file(i))), position='append') write(unitnum,"()") write(unitnum,data_formatter) time,hist_var(:) From 78cc02d6b80938ec6b5a747983b769a0bcad5881 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Mon, 8 Jul 2024 16:24:19 +0200 Subject: [PATCH 034/134] (CE-analysis) bug fix: feed rho in phys units to thermal energy calculation --- src/main/eos_idealplusrad.f90 | 6 +++--- src/utils/analysis_common_envelope.f90 | 9 +++++---- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/src/main/eos_idealplusrad.f90 b/src/main/eos_idealplusrad.f90 index df37e4902..72ecc22db 100644 --- a/src/main/eos_idealplusrad.f90 +++ b/src/main/eos_idealplusrad.f90 @@ -125,7 +125,7 @@ subroutine get_idealplusrad_enfromtemp(densi,tempi,mu,eni) real, intent(in) :: densi,tempi,mu real, intent(out) :: eni - eni = egas_from_rhoT(densi,tempi,mu) + erad_from_rhoT(densi,tempi,mu) + eni = egas_from_rhoT(tempi,mu) + erad_from_rhoT(densi,tempi,mu) end subroutine get_idealplusrad_enfromtemp @@ -135,8 +135,8 @@ end subroutine get_idealplusrad_enfromtemp ! Calculates specific gas energy from density and temperature !+ !---------------------------------------------------------------- -real function egas_from_rhoT(densi,tempi,mu) result(egasi) - real, intent(in) :: densi,tempi,mu +real function egas_from_rhoT(tempi,mu) result(egasi) + real, intent(in) :: tempi,mu egasi = 1.5*Rg*tempi/mu diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index cbaa2cf73..07ac58cf6 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -3786,10 +3786,11 @@ subroutine calc_gas_energies(particlemass,poten,xyzh,vxyzu,rad,xyzmh_ptmass,phii real, intent(in) :: xyzh(:),vxyzu(:),rad(:) real, dimension(5,nptmass), intent(in) :: xyzmh_ptmass real, intent(out) :: phii,epoti,ekini,egasi,eradi,ereci,etoti - real :: fxi,fyi,fzi,rhoi,spsoundi,ponrhoi,presi,tempi,egasradi + real :: fxi,fyi,fzi,rhoi,rho_cgs,spsoundi,ponrhoi,presi,tempi,egasradi integer :: ierr rhoi = rhoh(xyzh(4),particlemass) + rho_cgs = rhoi*unit_density phii = 0. call get_accel_sink_gas(nptmass,xyzh(1),xyzh(2),xyzh(3),xyzh(4),xyzmh_ptmass,fxi,fyi,fzi,phii) epoti = 2.*poten + particlemass * phii ! For individual particles, need to multiply 2 to poten to get \sum_j G*mi*mj/r @@ -3815,9 +3816,9 @@ subroutine calc_gas_energies(particlemass,poten,xyzh,vxyzu,rad,xyzmh_ptmass,phii call calc_thermal_energy(particlemass,10,xyzh,vxyzu,presi,tempi,egasradi,rad) ereci = vxyzu(4)*particlemass - egasradi case(12) - call get_idealplusrad_temp(rhoi,vxyzu(4)*unit_ergg,gmw,tempi,ierr) - egasi = egas_from_rhoT(rhoi,tempi,gmw)*particlemass - eradi = erad_from_rhoT(rhoi,tempi,gmw)*particlemass + call get_idealplusrad_temp(rho_cgs,vxyzu(4)*unit_ergg,gmw,tempi,ierr) + egasi = egas_from_rhoT(tempi,gmw)/unit_ergg*particlemass + eradi = erad_from_rhoT(rho_cgs,tempi,gmw)/unit_ergg*particlemass egasradi = egasi + eradi case default call fatal('calc_gas_energies',"EOS type not supported (currently, only supporting ieos=2,10,12)") From 952a54025752cd414c4cbec74e1dd276250b8191 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Fri, 9 Aug 2024 12:21:26 +0100 Subject: [PATCH 035/134] bug fix for radapprox cooling --- src/main/step_leapfrog.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 8679970a7..713b59446 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -375,6 +375,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (npart > 0) then if (gr) vpred = vxyzu ! Need primitive utherm as a guess in cons2prim + if (icooling == 8) vpred(4,:) = vxyzu(4,:) ! only evolve u in cooling dt_too_small = .false. call derivs(1,npart,nactive,xyzh,vpred,fxyzu,fext,divcurlv,& divcurlB,Bpred,dBevol,radpred,drad,radprop,dustproppred,ddustprop,& From 2edd6e8449f6dceafcfb6abf05f66bdf82ba7588 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Wed, 4 Sep 2024 14:53:12 +0200 Subject: [PATCH 036/134] (CE-analysis) change writing of divv files to splash extra-column files --- src/main/inject_rochelobe.f90 | 1 - src/utils/analysis_common_envelope.f90 | 324 ++++++++++++------------- 2 files changed, 161 insertions(+), 164 deletions(-) diff --git a/src/main/inject_rochelobe.f90 b/src/main/inject_rochelobe.f90 index ffe84d4dd..5aa329cd2 100644 --- a/src/main/inject_rochelobe.f90 +++ b/src/main/inject_rochelobe.f90 @@ -165,7 +165,6 @@ subroutine inject_particles(time,dtlast,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& h = hfact*sw_chi/udist !add the particle call add_or_update_particle(part_type, xyzi, vxyz, h, u, i_part, npart, npartoftype, xyzh, vxyzu) - enddo ! !-- no constraint on timestep diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index cbaa2cf73..3f2140ce3 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -71,7 +71,7 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) ' 5) Roche-lobe utils', & ' 6) Star stabilisation suite', & ' 7) Simulation units and particle properties', & - ' 8) Output .divv', & + ' 8) Output extra quantities', & ' 9) EoS testing', & '10) Profile of newly unbound particles', & '11) Sink properties', & @@ -129,8 +129,8 @@ subroutine do_analysis(dumpfile,num,xyzh,vxyzu,particlemass,npart,time,iunit) call star_stabilisation_suite(time,npart,particlemass,xyzh,vxyzu) case(7) !Units call print_simulation_parameters(npart,particlemass) - case(8) !Output .divv - call output_divv_files(time,dumpfile,npart,particlemass,xyzh,vxyzu) + case(8) ! output extra quantities + call output_extra_quantities(time,dumpfile,npart,particlemass,xyzh,vxyzu) case(9) !EoS testing call eos_surfaces case(10) !New unbound particle profiles in time @@ -1274,110 +1274,183 @@ end subroutine print_simulation_parameters !---------------------------------------------------------------- !+ -! Write quantities (up to four) to divv file +! Write extra quantities to .extras files +! These files can be read via splash --extracols=[label1],[label2],... !+ !---------------------------------------------------------------- -subroutine output_divv_files(time,dumpfile,npart,particlemass,xyzh,vxyzu) +subroutine output_extra_quantities(time,dumpfile,npart,particlemass,xyzh,vxyzu) use part, only:eos_vars,itemp,nucleation,idK0,idK1,idK2,idK3,idJstar,idmu,idgamma use eos, only:entropy 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:ionisation_fraction - use dust_formation, only:psat_C,eps,set_abundances,mass_per_H, chemical_equilibrium_light, calc_nucleation!, Scrit - !use dim, only:nElements + use dust_formation, only:psat_C,eps,set_abundances,mass_per_H,chemical_equilibrium_light,calc_nucleation integer, intent(in) :: npart character(len=*), intent(in) :: dumpfile real, intent(in) :: time,particlemass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - integer :: i,k,Nquantities,ierr,iu - integer, save :: quantities_to_calculate(4) - integer, allocatable :: iorder(:) + character(len=30) :: msg + character(len=17), allocatable:: labels(:) + integer :: i,k,Noptions,ierr + integer, save :: Nquant + integer, save, allocatable :: quants(:) + integer, allocatable :: iorder(:),iu(:) real :: ekini,epoti,egasi,eradi,ereci,ethi,phii,rho_cgs,ponrhoi,spsoundi,tempi,& - omega_orb,kappai,kappat,kappar,pgas,mu,entropyi,rhopart,& + omega_orb,kappai,kappat,kappar,pgas,mu,entropyi,rhopart,v_esci,& dum1,dum2,dum3,dum4,dum5 + real :: pC,pC2,pC2H,pC2H2,nH_tot,epsC,S,taustar,taugr,JstarS real, allocatable, save :: init_entropy(:) - real, allocatable :: quant(:,:) - real, dimension(3) :: com_xyz,com_vxyz,xyz_a,vxyz_a - real :: pC, pC2, pC2H, pC2H2, nH_tot, epsC, S - real :: taustar, taugr, JstarS - real :: v_esci + real, allocatable :: arr(:,:) + real, dimension(3) :: com_xyz,com_vxyz,xyz_a,vxyz_a,sinkcom_xyz,sinkcom_vxyz real, parameter :: Scrit = 2. ! Critical saturation ratio - logical :: verbose = .false. + logical :: req_eos_call,req_gas_energy,req_thermal_energy,verbose=.false. + + Noptions = 13 + allocate(labels(Noptions)) + labels = (/ 'e_kpt ',& + 'e_kp ',& + 'erec ',& + 'mach ',& + 'kappa ',& + 'omega_sinkCM',& + 'omega_core ',& + 'delta_omega ',& + 'entropy_mesa',& + 'entropy_gain',& + 'm ',& + 'vesc ',& + 'JstarS '& + /) - allocate(quant(4,npart)) - Nquantities = 14 if (dump_number == 0) then - print "(14(a,/))",& + call prompt('Enter number of extra quantities to write out: ',Nquant,0) + allocate(quants(Nquant)) + + print "(13(a,/))",& '1) Total energy (kin + pot + therm)', & - '2) Mach number', & - '3) Opacity from MESA tables', & - '4) Gas omega w.r.t. effective CoM', & - '5) Fractional difference between gas and orbital omega', & - '6) MESA EoS specific entropy', & - '7) Fractional entropy gain', & - '8) Specific recombination energy', & - '9) Total energy (kin + pot)', & - '10) Mass coordinate', & - '11) Gas omega w.r.t. CoM', & - '12) Gas omega w.r.t. sink 1',& - '13) JstarS', & - '14) Escape velocity' - - quantities_to_calculate = (/1,2,4,5/) - call prompt('Choose first quantity to compute ',quantities_to_calculate(1),0,Nquantities) - call prompt('Choose second quantity to compute ',quantities_to_calculate(2),0,Nquantities) - call prompt('Choose third quantity to compute ',quantities_to_calculate(3),0,Nquantities) - call prompt('Choose fourth quantity to compute ',quantities_to_calculate(4),0,Nquantities) + '2) Total energy (kin + pot)', & + '3) Specific recombination energy', & + '4) Mach number', & + '5) Opacity from MESA tables', & + '6) Gas omega w.r.t. sink CoM', & + '7) Gas omega w.r.t. sink 1',& + '8) Fractional difference between gas and orbital omega w.r.t. sink CoM', & + '9) MESA EoS specific entropy', & + '10) Fractional entropy gain', & + '11) Mass coordinate', & + '12) Escape velocity', & + '13) JstarS' + + do i=1,Nquant + write(msg, '(a,i2,a)') 'Enter quantity ',i,':' + call prompt(msg,quants(i),0,Noptions) + enddo endif + allocate(arr(Nquant,npart),iu(Nquant)) + arr = 0. + ! Calculations performed outside loop over particles call compute_energies(time) omega_orb = 0. com_xyz = 0. com_vxyz = 0. - do k=1,4 - select case (quantities_to_calculate(k)) - case(0,1,2,3,6,8,9,13,14) ! Nothing to do - case(4,5,11,12) ! Fractional difference between gas and orbital omega - if (quantities_to_calculate(k) == 4 .or. quantities_to_calculate(k) == 5) then - com_xyz = (xyzmh_ptmass(1:3,1)*xyzmh_ptmass(4,1) + xyzmh_ptmass(1:3,2)*xyzmh_ptmass(4,2)) & - / (xyzmh_ptmass(4,1) + xyzmh_ptmass(4,2)) - com_vxyz = (vxyz_ptmass(1:3,1)*xyzmh_ptmass(4,1) + vxyz_ptmass(1:3,2)*xyzmh_ptmass(4,2)) & - / (xyzmh_ptmass(4,1) + xyzmh_ptmass(4,2)) - elseif (quantities_to_calculate(k) == 11 .or. quantities_to_calculate(k) == 12) then - com_xyz = xyzmh_ptmass(1:3,1) - com_vxyz = vxyz_ptmass(1:3,1) - endif - do i=1,nptmass - 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) - omega_orb = omega_orb + 0.5 * (-xyz_a(2) * vxyz_a(1) + xyz_a(1) * vxyz_a(2)) / dot_product(xyz_a(1:2), xyz_a(1:2)) - enddo - case(7) - if (dump_number==0) allocate(init_entropy(npart)) - case(10) - call set_r2func_origin(0.,0.,0.) - allocate(iorder(npart)) - call indexxfunc(npart,r2func_origin,xyzh,iorder) - deallocate(iorder) - case default - print*,"Error: Requested quantity is invalid." - stop - end select - enddo + epoti = 0. + ekini = 0. + + req_eos_call = any(quants==1 .or. quants==2 .or. quants==4 .or. quants==6 .or. quants==7 & + .or. quants==9 .or. quants==10 .or. quants==13) + req_gas_energy = any(quants==1 .or. quants==2 .or. quants==3) + req_thermal_energy = any(quants==1 .or. quants==3) + + if (any(quants==6 .or. quants==8)) then + sinkcom_xyz = (xyzmh_ptmass(1:3,1)*xyzmh_ptmass(4,1) + xyzmh_ptmass(1:3,2)*xyzmh_ptmass(4,2)) & + / (xyzmh_ptmass(4,1) + xyzmh_ptmass(4,2)) + sinkcom_vxyz = (vxyz_ptmass(1:3,1)*xyzmh_ptmass(4,1) + vxyz_ptmass(1:3,2)*xyzmh_ptmass(4,2)) & + / (xyzmh_ptmass(4,1) + xyzmh_ptmass(4,2)) + endif + + if (any(quants==11)) then + call set_r2func_origin(0.,0.,0.) + allocate(iorder(npart)) + call indexxfunc(npart,r2func_origin,xyzh,iorder) + endif + + if (any(quants==10) .and. dump_number==0) allocate(init_entropy(npart)) + + if (any(quants==13)) call set_abundances ! set initial abundances to get mass_per_H + - !set initial abundances to get mass_per_H - call set_abundances - ! Calculations performed in loop over particles do i=1,npart - do k=1,4 - select case (quantities_to_calculate(k)) + rhopart = rhoh(xyzh(4,i),particlemass) + rho_cgs = rhopart*unit_density + if (req_eos_call) then + call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) + endif + + if (req_gas_energy) then + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,& + epoti,ekini,egasi,eradi,ereci,dum1) + endif + + if (req_thermal_energy) then + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) + endif + + do k=1,Nquant + select case (quants(k)) + case(1) ! Total energy (kin + pot + therm) + arr(k,i) = (ekini + epoti + ethi) / particlemass + case(2) ! Total energy (kin + pot) + arr(k,i) = (ekini + epoti) / particlemass + case(3) ! Specific recombination energy + arr(k,i) = vxyzu(4,i) - ethi / particlemass + case(4) ! Mach number + arr(k,i) = distance(vxyzu(1:3,i)) / spsoundi + case(5) ! Opacity from MESA tables + call ionisation_fraction(rho_cgs,eos_vars(itemp,i),X_in,1.-X_in-Z_in,dum1,dum2,dum3,dum4,dum5) + if (ieos == 10) then + call get_eos_kappa_mesa(rho_cgs,eos_vars(itemp,i),kappai,kappat,kappar) + arr(k,i) = kappai + else + arr(k,i) = 0. + endif + case(6) ! Gas omega w.r.t. sink CoM + xyz_a = xyzh(1:3,i) - sinkcom_xyz(1:3) + vxyz_a = vxyzu(1:3,i) - sinkcom_vxyz(1:3) + arr(k,i) = (-xyz_a(2) * vxyz_a(1) + xyz_a(1) * vxyz_a(2)) / dot_product(xyz_a(1:2), xyz_a(1:2)) + case(7) ! Gas omega w.r.t. sink 1 + xyz_a = xyzh(1:3,i) - xyzmh_ptmass(1:3,1) + vxyz_a = vxyzu(1:3,i) - vxyz_ptmass(1:3,1) + arr(k,i) = (-xyz_a(2) * vxyz_a(1) + xyz_a(1) * vxyz_a(2)) / dot_product(xyz_a(1:2), xyz_a(1:2)) + case(8) ! Fractional difference between gas and orbital omega + xyz_a = xyzh(1:3,i) - sinkcom_xyz(1:3) + vxyz_a = vxyzu(1:3,i) - sinkcom_vxyz(1:3) + omega_orb = omega_orb + 0.5 * (-xyz_a(2) * vxyz_a(1) + xyz_a(1) * vxyz_a(2)) / dot_product(xyz_a(1:2), xyz_a(1:2)) + arr(k,i) = (-xyz_a(2) * vxyz_a(1) + xyz_a(1) * vxyz_a(2)) / dot_product(xyz_a(1:2), xyz_a(1:2)) + arr(k,i) = arr(k,i)/omega_orb - 1. + case(9,10) ! Calculate MESA EoS entropy + entropyi = 0. + if (ieos==10) then + call getvalue_mesa(rho_cgs,vxyzu(4,i)*unit_ergg,3,pgas,ierr) ! Get gas pressure + mu = rho_cgs * Rg * eos_vars(itemp,i) / pgas + entropyi = entropy(rho_cgs,ponrhoi*rhopart*unit_pressure,mu,3,vxyzu(4,i)*unit_ergg,ierr) + elseif (ieos==2) then + entropyi = entropy(rho_cgs,ponrhoi*rhopart*unit_pressure,gmw,1) + endif + if (quants(k) == 10) then + if (dump_number == 0) init_entropy(i) = entropyi ! Store initial entropy on each particle + arr(k,i) = entropyi/init_entropy(i) - 1. + elseif (quants(k) == 9) then + arr(k,i) = entropyi + endif + case(11) ! Mass coordinate + arr(k,iorder(i)) = real(i,kind=kind(time)) * particlemass + case(12) ! Escape_velocity + call calc_escape_velocities(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,v_esci) + arr(k,i) = v_esci case(13) !to calculate JstarS - rhopart = rhoh(xyzh(4,i), particlemass) - rho_cgs = rhopart*unit_density - !call equationofstate to obtain temperature and store it in tempi - call equationofstate(ieos,ponrhoi,spsoundi,rhopart,xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) JstarS = 0. !nH_tot is needed to normalize JstarS nH_tot = rho_cgs/mass_per_H @@ -1413,97 +1486,22 @@ subroutine output_divv_files(time,dumpfile,npart,particlemass,xyzh,vxyzu) print *,'eps = ',eps print *,'JstarS = ',JstarS endif - quant(k,i) = JstarS - - case(0) ! Skip - quant(k,i) = 0. - - 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),rad(:,i),xyzmh_ptmass,phii,& - epoti,ekini,egasi,eradi,ereci,dum1) - if (quantities_to_calculate(k)==1) then - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) - quant(k,i) = (ekini + epoti + ethi) / particlemass ! Specific energy - elseif (quantities_to_calculate(k)==9) then - quant(k,i) = (ekini + epoti) / particlemass ! Specific energy - endif - - case(2) ! Mach number - 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)) - quant(k,i) = distance(vxyzu(1:3,i)) / spsoundi - - case(3) ! Opacity from MESA tables - rhopart = rhoh(xyzh(4,i), particlemass) - call ionisation_fraction(rhopart*unit_density,eos_vars(itemp,i),X_in,1.-X_in-Z_in,dum1,dum2,dum3,dum4,dum5) - if (ieos == 10) then - call get_eos_kappa_mesa(rhopart*unit_density,eos_vars(itemp,i),kappai,kappat,kappar) - quant(k,i) = kappai - else - quant(k,i) = 0. - endif - - case(4,11,12) ! Gas omega w.r.t. effective CoM - xyz_a = xyzh(1:3,i) - com_xyz(1:3) - vxyz_a = vxyzu(1:3,i) - com_vxyz(1:3) - quant(k,i) = (-xyz_a(2) * vxyz_a(1) + xyz_a(1) * vxyz_a(2)) / dot_product(xyz_a(1:2), xyz_a(1:2)) - - case(5) ! Fractional difference between gas and orbital omega - xyz_a = xyzh(1:3,i) - com_xyz(1:3) - vxyz_a = vxyzu(1:3,i) - com_vxyz(1:3) - quant(k,i) = (-xyz_a(2) * vxyz_a(1) + xyz_a(1) * vxyz_a(2)) / dot_product(xyz_a(1:2), xyz_a(1:2)) - quant(k,i) = (quant(k,i) - omega_orb) / omega_orb - - case(6,7) ! Calculate MESA EoS entropy - entropyi = 0. - 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)) - if (ieos==10) then - call getvalue_mesa(rhopart*unit_density,vxyzu(4,i)*unit_ergg,3,pgas,ierr) ! Get gas pressure - mu = rhopart*unit_density * Rg * eos_vars(itemp,i) / pgas - entropyi = entropy(rhopart*unit_density,ponrhoi*rhopart*unit_pressure,mu,3,vxyzu(4,i)*unit_ergg,ierr) - elseif (ieos==2) then - entropyi = entropy(rhopart*unit_density,ponrhoi*rhopart*unit_pressure,gmw,1) - endif - - if (quantities_to_calculate(k) == 7) then - if (dump_number == 0) then - init_entropy(i) = entropyi ! Store initial entropy on each particle - endif - quant(k,i) = entropyi/init_entropy(i) - 1. - elseif (quantities_to_calculate(k) == 6) then - quant(k,i) = entropyi - endif - - case(8) ! Specific recombination 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_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) - quant(k,i) = vxyzu(4,i) - ethi / particlemass ! Specific energy - - case(10) ! Mass coordinate - quant(k,iorder(i)) = real(i,kind=kind(time)) * particlemass - - case(14) ! Escape_velocity - call calc_escape_velocities(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),xyzmh_ptmass,phii,epoti,v_esci) - quant(k,i) = v_esci + arr(k,i) = JstarS case default - print*,"Error: Requested quantity is invalid." - stop + call fatal('analysis_common_envelope','Requested quantity is invalid.') end select enddo enddo - open(newunit=iu,file=trim(dumpfile)//".divv",status='replace',form='unformatted') - do k=1,4 - write(iu) (quant(k,i),i=1,npart) + ! Open files + do k=1,Nquant + open(newunit=iu(k),file=trim(dumpfile)//"."//trim(labels(quants(k)))//".extras",status='replace',form='unformatted') + write(iu(k)) (arr(k,i),i=1,npart) + close(iu(k)) enddo - close(iu) - deallocate(quant) + deallocate(arr) -end subroutine output_divv_files +end subroutine output_extra_quantities @@ -3794,7 +3792,7 @@ subroutine calc_gas_energies(particlemass,poten,xyzh,vxyzu,rad,xyzmh_ptmass,phii call get_accel_sink_gas(nptmass,xyzh(1),xyzh(2),xyzh(3),xyzh(4),xyzmh_ptmass,fxi,fyi,fzi,phii) 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)) - + egasradi = 0. egasi = 0. ereci = 0. if (do_radiation) then From d321d38fb452e0da09e5265144bc83dcab91a1e8 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Wed, 4 Sep 2024 16:37:07 +0200 Subject: [PATCH 037/134] bug fix: add forgotten argument to radxi_from_Trad --- src/setup/set_star_utils.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index 26e32e4cc..9d4c8e7ab 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -440,7 +440,7 @@ subroutine set_star_thermalenergy(ieos,den,pres,r,npts,npart,xyzh,vxyzu,rad,eos_ endif if (do_radiation) then vxyzu(4,i) = ugas_from_Tgas(tempi,gamma,gmw) - rad(iradxi,i) = radxi_from_Trad(tempi) + rad(iradxi,i) = radxi_from_Trad(densi,tempi) else vxyzu(4,i) = eni / unit_ergg endif From 3483fac0dc9aa71a1dc5e133ca5d69c81ebc4c66 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Thu, 5 Sep 2024 01:15:10 +1000 Subject: [PATCH 038/134] merge changes --- src/utils/analysis_common_envelope.f90 | 34 +++++++++++--------------- 1 file changed, 14 insertions(+), 20 deletions(-) diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 199198056..7a11023b9 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -1478,10 +1478,6 @@ subroutine output_extra_quantities(time,dumpfile,npart,particlemass,xyzh,vxyzu) print *,'epsC = ',epsC print *,'tempi = ',tempi print *,'S = ',S - print *,'pC =',pC - print *,'psat_C(tempi) = ',psat_C(tempi) - print *,'nucleation(idmu,i) = ',nucleation(idmu,i) - print *,'nucleation(idgamma,i) = ',nucleation(idgamma,i) print *,'taustar = ',taustar print *,'eps = ',eps print *,'JstarS = ',JstarS @@ -2764,8 +2760,7 @@ subroutine recombination_stats(time,num,npart,particlemass,xyzh,vxyzu) real :: etoti,ekini,egasi,eradi,ereci,epoti,ethi,phii,dum,rhopart,& ponrhoi,spsoundi,tempi,pressure,temperature,xh0,xh1,xhe0,xhe1,xhe2 character(len=40) :: data_formatter,logical_format - logical, allocatable :: isbound(:) - integer, allocatable :: H_state(:),He_state(:) + integer, allocatable :: H_state(:),He_state(:),isbound(:) integer :: i real, parameter :: recomb_th=0.05 @@ -2777,17 +2772,16 @@ 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),rad(:,i),xyzmh_ptmass,phii,epoti,ekini,egasi,eradi,ereci,dum) - call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi) - etoti = ekini + epoti + ethi + call calc_thermal_energy(particlemass,ieos,xyzh(:,i),vxyzu(:,i),ponrhoi*rhopart,eos_vars(itemp,i),ethi,rad(:,i)) + 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 - call ionisation_fraction(rhopart*unit_density,temperature,X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) + call ionisation_fraction(rhopart*unit_density,tempi,X_in,1.-X_in-Z_in,xh0,xh1,xhe0,xhe1,xhe2) ! Is unbound? if (etoti > 0.) then - isbound(i) = .false. + isbound(i) = 0 else - isbound(i) = .true. + isbound(i) = 1 endif ! H ionisation state @@ -2811,8 +2805,8 @@ subroutine recombination_stats(time,num,npart,particlemass,xyzh,vxyzu) endif enddo - write(data_formatter, "(a,I5,a)") "(es18.10e3,", npart, "(1x,i1))" ! Time column plus npart columns - write(logical_format, "(a,I5,a)") "(es18.10e3,", npart, "(1x,L))" ! Time column plus npart columns + write(data_formatter, "(a,I7,a)") "(es18.10e3,", npart, "(1x,i1))" ! Time column plus npart columns + write(logical_format, "(a,I7,a)") "(es18.10e3,", npart, "(1x,i1))" ! Time column plus npart columns if (num == 0) then ! Write header line open(unit=1000,file="H_state.ev",status='replace') @@ -2830,13 +2824,13 @@ subroutine recombination_stats(time,num,npart,particlemass,xyzh,vxyzu) write(1000,data_formatter) time,H_state(:) close(unit=1000) - open(unit=1000,file="He_state.ev", position='append') - write(1000,data_formatter) time,He_state(:) - close(unit=1000) + open(unit=1001,file="He_state.ev", position='append') + write(1001,data_formatter) time,He_state(:) + close(unit=1001) - open(unit=1000,file="isbound.ev", position='append') - write(1000,logical_format) time,isbound(:) - close(unit=1000) + open(unit=1002,file="isbound.ev", position='append') + write(1002,logical_format) time,isbound(:) + close(unit=1002) deallocate(isbound,H_state,He_state) From ae6d48dc391d8a4917bc5ff9ec22f97d6b39b699 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Mon, 9 Sep 2024 13:52:13 -0500 Subject: [PATCH 039/134] (eos) fix logic in entropy function --- src/main/eos.f90 | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/main/eos.f90 b/src/main/eos.f90 index c0323a254..39d79b6cc 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -953,13 +953,16 @@ function entropy(rho,pres,mu_in,ientropy,eint_in,ierr,T_in,Trad_in) entropy = kb_on_mh / mu * log(temp**1.5/rho) case(2) ! Include both gas and radiation contributions (up to additive constants) - if (present(Trad_in)) then - Trad = Trad_in - else - if (.not. present(T_in)) then - call get_idealgasplusrad_tempfrompres(pres,rho,mu,temp) ! First solve for temp from rho and pres - Trad = temp ! assume thermal equilibrium + if (present(T_in)) then + temp = T_in + if (present(Trad_in)) then + Trad = Trad_in + else + Trad = temp endif + else + call get_idealgasplusrad_tempfrompres(pres,rho,mu,temp) ! First solve for temp from rho and pres + Trad = temp endif ! check temp if (temp < tiny(0.)) call warning('entropy','temperature = 0 will give minus infinity with s entropy') From 9daca12696c9752763a1069020b2eb503e973cee Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Mon, 9 Sep 2024 13:52:44 -0500 Subject: [PATCH 040/134] (eos) get_p_from_rho_s should use Rg not kb_on_mh in temperature solving --- src/main/eos.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/main/eos.f90 b/src/main/eos.f90 index 39d79b6cc..7fe20028d 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -1051,7 +1051,7 @@ end subroutine get_rho_from_p_s !+ !----------------------------------------------------------------------- subroutine get_p_from_rho_s(ieos,S,rho,mu,P,temp) - use physcon, only:kb_on_mh,radconst,rg,mass_proton_cgs,kboltz + use physcon, only:kb_on_mh,radconst,Rg,mass_proton_cgs,kboltz use io, only:fatal use eos_idealplusrad, only:get_idealgasplusrad_tempfrompres,get_idealplusrad_pres use units, only:unit_density,unit_pressure,unit_ergg @@ -1072,7 +1072,7 @@ subroutine get_p_from_rho_s(ieos,S,rho,mu,P,temp) select case (ieos) case (2,5,17) temp = (cgsrho * exp(mu*cgss*mass_proton_cgs))**(2./3.) - cgsP = cgsrho*kb_on_mh*temp / mu + cgsP = cgsrho*Rg*temp / mu case (12) corr = huge(corr) do while (abs(corr) > eoserr .and. niter < nitermax) From b10c7db073bf148750c3d57d939c0412a3573745 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Mon, 9 Sep 2024 14:10:25 -0500 Subject: [PATCH 041/134] delete or replace a bunch of kb_on_mh's --- src/main/eos.f90 | 10 +++++----- src/setup/set_star_utils.f90 | 4 ++-- src/setup/setup_star.f90 | 2 +- src/tests/test_gr.f90 | 2 +- 4 files changed, 9 insertions(+), 9 deletions(-) diff --git a/src/main/eos.f90 b/src/main/eos.f90 index 7fe20028d..5df8d12ca 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -840,7 +840,7 @@ end subroutine calc_rec_ene !+ !----------------------------------------------------------------------- subroutine calc_temp_and_ene(eos_type,rho,pres,ene,temp,ierr,guesseint,mu_local,X_local,Z_local) - use physcon, only:kb_on_mh + use physcon, only:Rg use eos_idealplusrad, only:get_idealgasplusrad_tempfrompres,get_idealplusrad_enfromtemp use eos_mesa, only:get_eos_eT_from_rhop_mesa use eos_gasradrec, only:calc_uT_from_rhoP_gasradrec @@ -861,7 +861,7 @@ subroutine calc_temp_and_ene(eos_type,rho,pres,ene,temp,ierr,guesseint,mu_local, if (present(Z_local)) Z = Z_local select case(eos_type) case(2,5,17) ! Ideal gas - temp = pres / (rho * kb_on_mh) * mu + temp = pres / (rho * Rg) * mu ene = pres / ( (gamma-1.) * rho) case(12) ! Ideal gas + radiation call get_idealgasplusrad_tempfrompres(pres,rho,mu,temp) @@ -889,7 +889,7 @@ end subroutine calc_temp_and_ene !+ !----------------------------------------------------------------------- subroutine calc_rho_from_PT(eos_type,pres,temp,rho,ierr,mu_local,X_local,Z_local) - use physcon, only:kb_on_mh + use physcon, only:Rg use eos_idealplusrad, only:get_idealplusrad_rhofrompresT use eos_mesa, only:get_eos_eT_from_rhop_mesa use eos_gasradrec, only:calc_uT_from_rhoP_gasradrec @@ -910,7 +910,7 @@ subroutine calc_rho_from_PT(eos_type,pres,temp,rho,ierr,mu_local,X_local,Z_local if (present(Z_local)) Z = Z_local select case(eos_type) case(2) ! Ideal gas - rho = pres / (temp * kb_on_mh) * mu + rho = pres / (temp * Rg) * mu case(12) ! Ideal gas + radiation call get_idealplusrad_rhofrompresT(pres,temp,mu,rho) case default @@ -1051,7 +1051,7 @@ end subroutine get_rho_from_p_s !+ !----------------------------------------------------------------------- subroutine get_p_from_rho_s(ieos,S,rho,mu,P,temp) - use physcon, only:kb_on_mh,radconst,Rg,mass_proton_cgs,kboltz + use physcon, only:radconst,Rg,mass_proton_cgs,kboltz use io, only:fatal use eos_idealplusrad, only:get_idealgasplusrad_tempfrompres,get_idealplusrad_pres use units, only:unit_density,unit_pressure,unit_ergg diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index 9d4c8e7ab..f616345e7 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -458,7 +458,7 @@ end subroutine set_star_thermalenergy !----------------------------------------------------------------------- subroutine solve_uT_profiles(eos_type,r,den,pres,Xfrac,Yfrac,regrid_core,temp,en,mu) use eos, only:get_mean_molecular_weight,calc_temp_and_ene - use physcon, only:radconst,kb_on_mh + use physcon, only:radconst,Rg integer, intent(in) :: eos_type real, intent(in) :: r(:),den(:),pres(:),Xfrac(:),Yfrac(:) logical, intent(in) :: regrid_core @@ -475,7 +475,7 @@ subroutine solve_uT_profiles(eos_type,r,den,pres,Xfrac,Yfrac,regrid_core,temp,en mu(i) = get_mean_molecular_weight(Xfrac(i),1.-Xfrac(i)-Yfrac(i)) ! only used in u, T calculation if ieos==2,12 if (i==1) then guessene = 1.5*pres(i)/den(i) ! initial guess - tempi = min((3.*pres(i)/radconst)**0.25, pres(i)*mu(i)/(den(i)*kb_on_mh)) ! guess for temperature + tempi = min((3.*pres(i)/radconst)**0.25, pres(i)*mu(i)/(den(i)*Rg)) ! guess for temperature else guessene = en(i-1) tempi = temp(i-1) diff --git a/src/setup/setup_star.f90 b/src/setup/setup_star.f90 index e6fa4a8eb..7f4ded993 100644 --- a/src/setup/setup_star.f90 +++ b/src/setup/setup_star.f90 @@ -33,7 +33,7 @@ module setup ! use io, only:fatal,error,warning,master use part, only:gravity,gr - use physcon, only:solarm,solarr,km,pi,c,kb_on_mh,radconst + use physcon, only:solarm,solarr,km,pi,c,radconst use options, only:nfulldump,iexternalforce,calc_erot,use_var_comp use timestep, only:tmax,dtmax use eos, only:ieos diff --git a/src/tests/test_gr.f90 b/src/tests/test_gr.f90 index 905a15a0d..bdc1ad0fa 100644 --- a/src/tests/test_gr.f90 +++ b/src/tests/test_gr.f90 @@ -468,7 +468,7 @@ subroutine test_cons2prim_i(x,v,dens,u,p,ncheck,nfail,errmax,tol) use part, only:ien_entropy,ien_etotal,ien_entropy_s use metric_tools, only:pack_metric,unpack_metric use eos, only:ieos,equationofstate,calc_temp_and_ene - use physcon, only:radconst,kb_on_mh + use physcon, only:radconst real, intent(in) :: x(1:3),v(1:3),dens,p,tol real, intent(inout) :: u From 300c3396afb42b4cc4639c1afbfa583bd34b64ec Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Mon, 9 Sep 2024 22:56:38 -0500 Subject: [PATCH 042/134] (CE-analysis) remove unused variables declared --- src/utils/analysis_common_envelope.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 4b8a17d35..ba9fecc06 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -2758,7 +2758,7 @@ subroutine recombination_stats(time,num,npart,particlemass,xyzh,vxyzu) real, intent(in) :: time,particlemass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) real :: etoti,ekini,egasi,eradi,ereci,epoti,ethi,phii,dum,rhopart,& - ponrhoi,spsoundi,tempi,pressure,temperature,xh0,xh1,xhe0,xhe1,xhe2 + ponrhoi,spsoundi,tempi,xh0,xh1,xhe0,xhe1,xhe2 character(len=40) :: data_formatter,logical_format integer, allocatable :: H_state(:),He_state(:),isbound(:) integer :: i From 99730c9e18a4699e4f376e7149e143b564cbe90e Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 10 Sep 2024 10:24:16 -0500 Subject: [PATCH 043/134] (CE-analysis) update test script --- scripts/test_analysis_ce.sh | 2 ++ src/utils/analysis_common_envelope.f90 | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/scripts/test_analysis_ce.sh b/scripts/test_analysis_ce.sh index a149860b8..cd718ce17 100755 --- a/scripts/test_analysis_ce.sh +++ b/scripts/test_analysis_ce.sh @@ -29,6 +29,7 @@ SEP no 2 1.667 +0.6182 0.6984 0.0142 BOUND @@ -38,4 +39,5 @@ BOUND no 2 1.667 +0.6182 ENERGIES diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index ba9fecc06..04e1ba8a7 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -4488,7 +4488,7 @@ subroutine set_eos_options(analysis_to_perform) gamma = 5./3. call prompt('Enter gamma:',gamma,0.) gmw = 0.618212823 - call prompt('Enter mean molecular weight for gas+rad EoS:',gmw,0.) + call prompt('Enter mean molecular weight:',gmw,0.) case(10,20) gamma = 5./3. X_in = 0.69843 From e0fdcf94510e46b442edb37fece2f30e6a59c057 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Thu, 12 Sep 2024 12:37:44 -0500 Subject: [PATCH 044/134] (CE-analysis) clean up newly unbound particles --- src/utils/analysis_common_envelope.f90 | 100 +++++++++---------------- 1 file changed, 34 insertions(+), 66 deletions(-) diff --git a/src/utils/analysis_common_envelope.f90 b/src/utils/analysis_common_envelope.f90 index 04e1ba8a7..692c4ef43 100644 --- a/src/utils/analysis_common_envelope.f90 +++ b/src/utils/analysis_common_envelope.f90 @@ -2494,89 +2494,59 @@ subroutine unbound_profiles(time,num,npart,particlemass,xyzh,vxyzu) integer, intent(in) :: npart,num real, intent(in) :: time,particlemass real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - integer, dimension(4) :: npart_hist - real, dimension(5,npart) :: dist_part,rad_part + integer, dimension(2) :: nunbound + real, dimension(2,npart) :: dist_part,rad_part real, dimension(:), allocatable :: hist_var - real :: etoti,ekini,ereci,egasi,eradi,epoti,phii,dum,maxloga,minloga - character(len=18), dimension(4) :: grid_file + real :: e_kp,e_kpt,etoti,ekini,ereci,egasi,eradi,epoti,phii,sep,maxloga,minloga + character(len=18), dimension(2) :: grid_file character(len=40) :: data_formatter - logical, allocatable, save :: prev_unbound(:,:),prev_bound(:,:) - integer :: i,unitnum,nbins + logical, allocatable, save :: prev_bound(:,:) + integer :: i,j,unitnum,nbins,maxj call compute_energies(time) - npart_hist = 0 ! Stores number of particles fulfilling each of the four bound/unbound criterion + nunbound = 0 ! Stores number of particles that have become newly unbound in this dump according to e_kp or e_kpt criterion nbins = 500 - rad_part = 0. ! (4,npart_hist)-array storing separations of particles - dist_part = 0. + rad_part = 0. ! (2,npart_hist)-array storing separations of newly unbound particles + dist_part = 0. ! Array of ones with size of 2? minloga = 0.5 maxloga = 4.3 allocate(hist_var(nbins)) - grid_file = (/ 'grid_unbound_th.ev', & - 'grid_unbound_kp.ev', & - ' grid_bound_kpt.ev', & - ' grid_bound_kp.ev' /) + grid_file = (/ 'grid_unbound_th.ev', 'grid_unbound_kp.ev' /) if (dump_number == 0) then allocate(prev_bound(2,npart)) - allocate(prev_unbound(2,npart)) - prev_bound = .false. - prev_unbound = .false. + prev_bound = .true. ! all particles bound to begin with endif - do i=1,npart - if (.not. isdead_or_accreted(xyzh(4,i))) then - call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,& - epoti,ekini,egasi,eradi,ereci,dum) - etoti = ekini + epoti + egasi + eradi - - ! Ekin + Epot + Eth > 0 - if ((etoti > 0.) .and. (.not. prev_unbound(1,i))) then - npart_hist(1) = npart_hist(1) + 1 ! Keeps track of number of particles that have become newly unbound in this dump - rad_part(1,npart_hist(1)) = separation(xyzh(1:3,i),xyzmh_ptmass(1:3,1)) - dist_part(1,npart_hist(1)) = 1. ! Array of ones with size of npart_hist(1)? - prev_unbound(1,i) = .true. - elseif (etoti < 0.) then - prev_unbound(1,i) = .false. - endif - - ! Ekin + Epot > 0 - if ((ekini + epoti > 0.) .and. (.not. prev_unbound(2,i))) then - npart_hist(2) = npart_hist(2) + 1 - rad_part(2,npart_hist(2)) = separation(xyzh(1:3,i),xyzmh_ptmass(1:3,1)) - dist_part(2,npart_hist(2)) = 1. - prev_unbound(2,i) = .true. - elseif (ekini + epoti < 0.) then - prev_unbound(2,i) = .false. - endif - - ! Ekin + Epot + Eth < 0 - if ((etoti < 0.) .and. (.not. prev_bound(1,i))) then - npart_hist(3) = npart_hist(3) + 1 - rad_part(3,npart_hist(3)) = separation(xyzh(1:3,i),xyzmh_ptmass(1:3,1)) - dist_part(3,npart_hist(3)) = 1. - prev_bound(1,i) = .true. - elseif (etoti > 0.) then - prev_bound(1,i) = .false. - endif - - ! Ekin + Epot < 0 - if ((ekini + epoti < 0.) .and. (.not. prev_bound(2,i))) then - npart_hist(4) = npart_hist(4) + 1 - rad_part(4,npart_hist(4)) = separation(xyzh(1:3,i),xyzmh_ptmass(1:3,1)) - dist_part(4,npart_hist(4)) = 1. - prev_bound(2,i) = .true. - elseif (ekini + epoti > 0.) then - prev_bound(2,i) = .false. - endif + if (isdead_or_accreted(xyzh(4,i))) cycle + call calc_gas_energies(particlemass,poten(i),xyzh(:,i),vxyzu(:,i),rad(:,i),xyzmh_ptmass,phii,& + epoti,ekini,egasi,eradi,ereci,etoti) + e_kp = ekini + epoti + e_kpt = e_kp + egasi + eradi + + if (e_kp > 0. .and. prev_bound(2,i)) then ! newly bound by e_kp criterion + maxj = 2 + sep = separation(xyzh(1:3,i),xyzmh_ptmass(1:3,1)) + elseif (e_kpt > 0. .and. prev_bound(1,i)) then ! newly bound by e_kpt but not e_kp criterion + maxj = 1 + sep = separation(xyzh(1:3,i),xyzmh_ptmass(1:3,1)) + else ! particle state has not changed + cycle endif + + do j = 1,maxj + nunbound(j) = nunbound(j) + 1 + rad_part(j,nunbound(j)) = sep + dist_part(j,nunbound(j)) = 1. + prev_bound(j,i) = .false. + enddo enddo - do i=1,4 - call histogram_setup(rad_part(i,1:npart_hist(i)),dist_part(i,1:npart_hist(i)),hist_var,npart_hist(i),maxloga,minloga,nbins,& + do i=1,2 + call histogram_setup(rad_part(i,1:nunbound(i)),dist_part(i,1:nunbound(i)),hist_var,nunbound(i),maxloga,minloga,nbins,& .false.,.true.) - write(data_formatter, "(a,I5,a)") "(", nbins+1, "(3x,es18.10e3,1x))" ! Time column plus nbins columns if (num == 0) then ! Write header line @@ -2586,10 +2556,8 @@ subroutine unbound_profiles(time,num,npart,particlemass,xyzh,vxyzu) endif open(newunit=unitnum,file=trim(adjustl(grid_file(i))), position='append') - write(unitnum,"()") write(unitnum,data_formatter) time,hist_var(:) - close(unit=unitnum) enddo deallocate(hist_var) From 29d08eec80ea89b37c198b7ab1d842e1ae78cbca Mon Sep 17 00:00:00 2001 From: Alison Young Date: Thu, 19 Sep 2024 10:56:25 +0100 Subject: [PATCH 045/134] Fix bug from merge. --- src/main/radiation_utils.f90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/main/radiation_utils.f90 b/src/main/radiation_utils.f90 index 4ac9b11ef..95dfb16de 100644 --- a/src/main/radiation_utils.f90 +++ b/src/main/radiation_utils.f90 @@ -411,13 +411,15 @@ end function get_kappa ! calculate opacities !+ !-------------------------------------------------------------------- -subroutine get_opacity(opacity_type,density,temperature,kappa) +subroutine get_opacity(opacity_type,density,temperature,kappa,u) + use eos_stamatellos, only:getopac_opdep use mesa_microphysics, only:get_kappa_mesa - use units, only:unit_density,unit_opacity + use units, only:unit_density,unit_opacity,unit_ergg real, intent(in) :: density, temperature + real, intent(in), optional :: u real, intent(out) :: kappa integer, intent(in) :: opacity_type - real :: kapt,kapr,rho_cgs + real :: kapt,kapr,rho_cgs,Ti,gmwi,gammai,kapBar,kappaPart select case(opacity_type) case(1) From c156cbf570cc59f4f48046e9f36d00085337d426 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Thu, 26 Sep 2024 11:07:25 +0100 Subject: [PATCH 046/134] Enable remote download of Lombardi EOS/opacity file --- data/eos/lombardi/README | 10 ++++++++++ src/main/datafiles.f90 | 2 ++ src/main/eos_stamatellos.f90 | 4 ++-- 3 files changed, 14 insertions(+), 2 deletions(-) create mode 100644 data/eos/lombardi/README diff --git a/data/eos/lombardi/README b/data/eos/lombardi/README new file mode 100644 index 000000000..9120e52cb --- /dev/null +++ b/data/eos/lombardi/README @@ -0,0 +1,10 @@ +The data tables for the equation of state and opacities for the modified Lombardi radiative cooling approximation are too large to be stored in the Phantom git repository. +They will be downloaded automatically when you run the code + +or can be retrieved manually using wget from Zenodo, e.g.: + +wget https://zenodo.org/records/13842491/files/eos_lom.dat + +The files are: + +eos_lom.dat diff --git a/src/main/datafiles.f90 b/src/main/datafiles.f90 index df791da0b..f41a85938 100644 --- a/src/main/datafiles.f90 +++ b/src/main/datafiles.f90 @@ -75,6 +75,8 @@ function map_dir_to_web(search_dir) result(url) url = 'https://zenodo.org/records/13162815/files/' case('data/starcluster') url = 'https://zenodo.org/records/13164858/files/' + case('data/eos/lombardi') + url = 'https://zenodo.org/records/13842491/files/' case default url = 'https://users.monash.edu.au/~dprice/'//trim(search_dir) end select diff --git a/src/main/eos_stamatellos.f90 b/src/main/eos_stamatellos.f90 index 11eaa0813..5877dcf64 100644 --- a/src/main/eos_stamatellos.f90 +++ b/src/main/eos_stamatellos.f90 @@ -21,7 +21,7 @@ module eos_stamatellos real,allocatable,public :: optable(:,:,:) real,allocatable,public :: Gpot_cool(:),duFLD(:),gradP_cool(:),lambda_FLD(:),urad_FLD(:) !gradP_cool=gradP/rho real,allocatable,public :: ttherm_store(:),teqi_store(:),opac_store(:),duSPH(:) - character(len=25), public :: eos_file= 'myeos.dat' !default name of tabulated EOS file + character(len=25), public :: eos_file= 'eos_lom.dat' !default name of tabulated EOS file logical,public :: doFLD = .True., floor_energy = .False. integer,public :: iunitst=19 integer,save :: nx,ny ! dimensions of optable read in @@ -81,7 +81,7 @@ subroutine read_optab(eos_file,ierr) character(len=120) :: filepath,junk ! read in data file for interpolation - filepath=find_phantom_datafile(eos_file,'cooling') + filepath=find_phantom_datafile(eos_file,'eos/lombardi') print *,"EOS file: FILEPATH:",filepath open(10, file=filepath, form="formatted", status="old",iostat=ierr) if (ierr > 0) return From a8d183f682d45c4222df88f08a85859ccffc2504 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Thu, 26 Sep 2024 11:09:30 +0100 Subject: [PATCH 047/134] Added eos_lom.dat to .gitignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 0a86fba6e..83990d4d7 100644 --- a/.gitignore +++ b/.gitignore @@ -30,3 +30,4 @@ _build *.cmod *.ilm *.stb +eos_lom.dat \ No newline at end of file From b85f54a33f72f42c80f39624fac80daeb520c550 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Thu, 26 Sep 2024 14:11:16 +0100 Subject: [PATCH 048/134] Bugfix for Github tests --- src/main/eos.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/main/eos.f90 b/src/main/eos.f90 index bce8ae55b..cbdaf9bf2 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -470,7 +470,7 @@ end subroutine equationofstate subroutine init_eos(eos_type,ierr) use units, only:unit_velocity use physcon, only:Rg - use io, only:error,warning,fatal + use io, only:error,warning use eos_mesa, only:init_eos_mesa use eos_helmholtz, only:eos_helmholtz_init use eos_piecewise, only:init_eos_piecewise @@ -562,7 +562,7 @@ subroutine init_eos(eos_type,ierr) case(23) call read_optab(eos_file,ierr) - if (ierr > 0) call fatal('init_eos','Failed to read EOS file',var='ierr',ival=ierr) + if (ierr > 0) call error('init_eos','Failed to read EOS file',var='ierr',ival=ierr) call init_S07cool end select From 42a79f0697456966e959221df0c78b43213d24a7 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Tue, 15 Oct 2024 16:14:09 +0100 Subject: [PATCH 049/134] Fix bug in ieos=23 init err --- src/main/eos.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/main/eos.f90 b/src/main/eos.f90 index cbdaf9bf2..8c0af1ce8 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -482,7 +482,7 @@ subroutine init_eos(eos_type,ierr) use dim, only:maxvxyzu,do_radiation integer, intent(in) :: eos_type integer, intent(out) :: ierr - integer :: ierr_mesakapp + integer :: ierr_mesakapp,ierr_ra ierr = 0 ! @@ -561,8 +561,8 @@ subroutine init_eos(eos_type,ierr) call init_eos_HIIR() case(23) - call read_optab(eos_file,ierr) - if (ierr > 0) call error('init_eos','Failed to read EOS file',var='ierr',ival=ierr) + call read_optab(eos_file,ierr_ra) + if (ierr_ra > 0) call warning('init_eos','Failed to read EOS file') call init_S07cool end select From 7207eb8b7fbc2cf7fa2dc26a0f982d76347635fb Mon Sep 17 00:00:00 2001 From: Alison Young Date: Wed, 16 Oct 2024 10:17:48 +0100 Subject: [PATCH 050/134] Removed unused variables --- src/main/dens.F90 | 1 - src/main/radiation_utils.f90 | 2 +- src/main/readwrite_dumps_fortran.f90 | 5 ++--- 3 files changed, 3 insertions(+), 5 deletions(-) diff --git a/src/main/dens.F90 b/src/main/dens.F90 index 9465f506d..e6fbd2801 100644 --- a/src/main/dens.F90 +++ b/src/main/dens.F90 @@ -1698,7 +1698,6 @@ subroutine calc_lambda_cell(cell,listneigh,nneigh,xyzh,xyzcache,vxyzu,iphase,gra real :: uradi,dradi,dradxi,dradyi,dradzi,runix,runiy,runiz real :: dT4,R_rad integer :: ngradh_err - real :: uradself ngradh_err = 0 over_parts: do icell = 1,cell%npcell diff --git a/src/main/radiation_utils.f90 b/src/main/radiation_utils.f90 index 95dfb16de..6197de6cb 100644 --- a/src/main/radiation_utils.f90 +++ b/src/main/radiation_utils.f90 @@ -419,7 +419,7 @@ subroutine get_opacity(opacity_type,density,temperature,kappa,u) real, intent(in), optional :: u real, intent(out) :: kappa integer, intent(in) :: opacity_type - real :: kapt,kapr,rho_cgs,Ti,gmwi,gammai,kapBar,kappaPart + real :: kapt,kapr,rho_cgs,Ti,gmwi,kapBar,kappaPart select case(opacity_type) case(1) diff --git a/src/main/readwrite_dumps_fortran.f90 b/src/main/readwrite_dumps_fortran.f90 index 208942da0..1ea3cfba4 100644 --- a/src/main/readwrite_dumps_fortran.f90 +++ b/src/main/readwrite_dumps_fortran.f90 @@ -71,7 +71,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) use timestep, only:dtmax,idtmax_n,idtmax_frac use part, only:ibin,krome_nmols,T_gas_cool use metric_tools, only:imetric, imet_et - use eos_stamatellos, only:gradP_cool,doFLD,urad_FLD,ttherm_store,teqi_store,opac_store + use eos_stamatellos, only:ttherm_store,teqi_store,opac_store real, intent(in) :: t character(len=*), intent(in) :: dumpfile integer, intent(in), optional :: iorder(:) @@ -249,8 +249,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) endif endif ! write stamatellos cooling values - if (icooling == 9) then ! .and. doFLD) then -! call write_array(1,urad_FLD,'urad',npart,k,ipass,idump,nums,ierrs(13)) + if (icooling == 9) then call write_array(1,teqi_store,'teqi',npart,k,ipass,idump,nums,nerr) call write_array(1,ttherm_store,'ttherm',npart,k,ipass,idump,nums,nerr) call write_array(1,opac_store,'opacity',npart,k,ipass,idump,nums,nerr) From 7bc52f5c671e895316e9b633409dcb807fd6322e Mon Sep 17 00:00:00 2001 From: Rebecca Nealon Date: Wed, 16 Oct 2024 11:06:46 +0100 Subject: [PATCH 051/134] (apr) adding APR --- .gitignore | 7 + build/Makefile | 12 +- build/Makefile_setups | 9 +- docs/user-guide/apr_guide.rst | 120 ++++ docs/user-guide/index.rst | 1 + src/main/apr.f90 | 782 +++++++++++++++++++++++++++ src/main/apr_region.f90 | 102 ++++ src/main/centreofmass.f90 | 65 ++- src/main/checkconserved.f90 | 16 +- src/main/checksetup.f90 | 9 +- src/main/config.F90 | 12 + src/main/cons2prim.f90 | 38 +- src/main/dens.F90 | 129 +++-- src/main/deriv.F90 | 16 +- src/main/energies.F90 | 33 +- src/main/evolve.F90 | 30 +- src/main/force.F90 | 86 ++- src/main/initial.F90 | 41 +- src/main/kdtree.F90 | 292 +++++++++- src/main/kernel_WendlandC2.f90 | 2 +- src/main/linklist_kdtree.F90 | 11 +- src/main/mpi_dens.F90 | 10 +- src/main/mpi_force.F90 | 10 +- src/main/part.F90 | 26 +- src/main/partinject.F90 | 6 +- src/main/ptmass.F90 | 34 +- src/main/readwrite_dumps_common.f90 | 32 +- src/main/readwrite_dumps_fortran.f90 | 31 +- src/main/readwrite_infile.F90 | 21 +- src/main/relaxem.f90 | 249 +++++++++ src/main/step_leapfrog.F90 | 22 +- src/main/substepping.F90 | 50 +- src/main/utils_shuffleparticles.F90 | 4 +- src/main/writeheader.F90 | 3 +- src/setup/relax_star.f90 | 92 +++- src/setup/set_star_utils.f90 | 2 +- src/setup/setup_asteroidwind.f90 | 2 +- src/setup/setup_star.f90 | 18 +- src/setup/setup_wave.f90 | 23 +- src/tests/directsum.f90 | 13 +- src/tests/test_apr.f90 | 123 +++++ src/tests/test_derivs.F90 | 7 +- src/tests/test_gravity.f90 | 11 +- src/tests/test_kdtree.F90 | 2 +- src/tests/testsuite.F90 | 29 +- src/utils/einsteintk_wrapper.f90 | 9 +- src/utils/utils_disc.f90 | 4 +- 47 files changed, 2364 insertions(+), 282 deletions(-) create mode 100644 docs/user-guide/apr_guide.rst create mode 100644 src/main/apr.f90 create mode 100644 src/main/apr_region.f90 create mode 100644 src/main/relaxem.f90 create mode 100644 src/tests/test_apr.f90 diff --git a/.gitignore b/.gitignore index 0a86fba6e..89565ba53 100644 --- a/.gitignore +++ b/.gitignore @@ -26,7 +26,14 @@ forcing.dat *.tar .DS_Store _build +build/wind_profile1D.dat +build/radiation-test01explicit.ev +build/radiation-test01implicit.ev +build/radiation-test02explicit.ev +build/radiation-test02implicit.ev +build/test000 *.cmdx *.cmod *.ilm *.stb + diff --git a/build/Makefile b/build/Makefile index 74453f45e..a6f2abbd9 100644 --- a/build/Makefile +++ b/build/Makefile @@ -84,6 +84,7 @@ LIBTOOL=ar rcs # -DMHD ! magnetic fields # -DNONIDEALMHD ! non-ideal magnetic fields including ionisation; uses NICIL # -DLIGHTCURVE ! lightcurve estimation +# -DAPR ! live adaptive particle refinement include Makefile_setups @@ -295,6 +296,13 @@ endif ifeq ($(AOCC), yes) FPPFLAGS += -DAOCC endif + +SRCAPR=relaxem.f90 apr_region.f90 apr.f90 +ifeq ($(APR), yes) + FPPFLAGS += -DAPR + KERNEL=WendlandC2 +endif + # # kernel choice # @@ -537,7 +545,7 @@ SOURCES= physcon.f90 ${CONFIG} ${SRCKERNEL} io.F90 units.f90 \ ${SRCKROME} memory.f90 ${SRCREADWRITE_DUMPS} ${SRCINJECT} \ H2regions.f90 subgroup.f90 \ quitdump.f90 ptmass.F90\ - readwrite_infile.F90 dens.F90 force.F90 deriv.F90 energies.F90 sort_particles.f90 \ + dens.F90 force.F90 deriv.F90 ${SRCAPR} readwrite_infile.F90 energies.F90 sort_particles.f90 \ utils_shuffleparticles.F90 evwrite.f90 substepping.F90 step_leapfrog.F90 writeheader.F90 ${SRCAN} step_supertimestep.F90 \ mf_write.f90 evolve.F90 utils_orbits.f90 utils_linalg.f90 \ checksetup.f90 initial.F90 @@ -682,7 +690,7 @@ endif # 22/4/24: added setup_params to avoid weird build failure with ifort on Mac OS SRCTESTS=utils_testsuite.f90 ${TEST_FASTMATH} test_kernel.f90 \ - test_dust.f90 test_growth.f90 test_smol.F90 \ + ${SRCAPR} test_apr.f90 test_dust.f90 test_growth.f90 test_smol.F90 \ test_nonidealmhd.F90 directsum.f90 test_gravity.f90 \ test_derivs.F90 test_cooling.f90 test_eos_stratified.f90 \ test_eos.f90 test_externf.f90 test_rwdump.f90 \ diff --git a/build/Makefile_setups b/build/Makefile_setups index 3a0897eca..49568b745 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -354,7 +354,7 @@ ifeq ($(SETUP), galcen) endif ifeq ($(SETUP), starcluster) -# Cluster of stars (ptmass) +# Cluster of stars (ptmass) SETUPFILE= setup_starcluster.f90 KNOWN_SETUP=yes endif @@ -1048,6 +1048,13 @@ ifeq ($(SETUP), testgr) SETUPFILE= setup_grdisc.f90 endif +ifeq ($(SETUP), testapr) +# unit tests for apr + APR=yes + KNOWN_SETUP=yes + PERIODIC=yes +endif + ifeq ($(SETUP), flrw) # constant density FLRW cosmology with perturbations GR=yes diff --git a/docs/user-guide/apr_guide.rst b/docs/user-guide/apr_guide.rst new file mode 100644 index 000000000..d485a3c1d --- /dev/null +++ b/docs/user-guide/apr_guide.rst @@ -0,0 +1,120 @@ +Running phantom with APR +======================== + +APR allows you to arbitrarily set regions of your simulation to have different local resolutions. +A description of the method and our implementation can be found in Nealon & Price 2024 (under review) and +you should cite this work if you are using APR. + +The rules of this method are: + 1. A mass factor of 2 is allowed between adjacent refinement levels (e.g. one parent 0> two children) + 2. Regions are spherical but can be nested together like a layered onion + 3. You cannot have both refinement and derefinement in the same simulation, e.g. the base refinement level has to be either the maximum or minimum + 4. Try to ensure that particles have several sound crossing times between subsequent split/merge procedures to reduce noise + + +Compiling Phantom with APR +-------------------------- +Use your usual setup routine but with APR=yes. For example: + +:: + + mkdir mycalc + cd mycalc + ~/phantom/scripts/writemake.sh disc > Makefile + export APR=yes + make setup + make + +Initial conditions with APR +------------------------- +APR does not affect any setups except SETUP=star (but for the relax procedure only). When you check your .in file it will have apr options at the bottom: + +:: + + apr_max = 3 ! number of additional refinement levels (3 -> 2x resolution) + +This option sets how many *extra* levels of refinement you want. Each level corresponds to a factor of 2 in mass. +To increase the spatial resolution by a factor of 2 you will need to use 3 levels here. + +:: + + ref_dir = 1 ! increase (1) or decrease (-1) resolution + +This chooses whether you are refining or derefining the simulation. If you are refining then the base resolution level will be 0. +If you are derefining the base level will be apr_max. + +:: + + apr_type = 2 ! 1: static, 2: moving sink, 3: create clumps + +Here you choose what kind of region you want. Current options include: + 1. A position fixed in space + 2. Tracking a particular sink particle + 3. Tracking a gravitationally bound clump (under development). +Depending on what you choose here you will get additional options to describe the properties of the region you selected. +You may need to re-run to get the right options if you alter apr_type. To add your own new region you can edit the apr_region.f90 file. +Note for now that we only allow spherical regions. + +:: + + apr_rad = 5. ! radius of innermost region + +This chooses the radius of the core of the refinement zone, where the highest/lowest refinement will be. If you think about +your refinement zone as an onion, this is the core of the onion. + +:: + + apr_drad = 10. ! size of step to next region + +This chooses the step width of the nested regions – the width of the shells as you step up your resolution. + +Running with APR +-------------------- +When APR is implemented and being used Phantom prints out the following statement in the log file: + +:: + + Adapative particle refinement is ON + +Additionally, because the particle numbers are changing each step you should see the number of +particles being updated during the steps e.g.: + +:: + +> step 2 / 16 t = 20.92159 dt = 0.072 moved 502 in 0.058 cpu-s < | np = 37902 | +> step 4 / 16 t = 21.06588 dt = 0.072 moved 1792 in 0.070 cpu-s < +> step 6 / 16 t = 21.21017 dt = 0.072 moved 319 in 0.058 cpu-s < +> step 8 / 16 t = 21.35445 dt = 0.072 moved 6175 in 0.097 cpu-s < +> step 10 / 16 t = 21.49874 dt = 0.072 moved 442 in 0.057 cpu-s < | np = 37901 | +> step 12 / 16 t = 21.64303 dt = 0.072 moved 1283 in 0.064 cpu-s < +> step 14 / 16 t = 21.78732 dt = 0.072 moved 476 in 0.058 cpu-s < | np = 37900 | +> step 16 / 16 t = 21.93160 dt = 0.072 moved 37860 in 0.31 cpu-s < + +Plotting with APR +-------------------- +APR is natively read by both splash and sarracen. The easiest way to check the method is working exactly +as you expect is to scatter plot (not render!) the mass of the particles in your simulation. This will +show you where the refinement zone is and you can confirm the geometry, it’s evolution as well as the +refinement direction. + +Analysis with APR +-------------------- +No analysis files that ship with Phantom have been updated to accommodate APR. To do this yourself, any +time you define a particle mass from the massoftype array you will need to edit it to read + +:: + + if (use_apr) then + pmassi = aprmassoftype(iamtypei,apr_level(i)) + else + pmassi = massoftype(iamtypei) + endif + +This relies on the apr_level, aprmassoftype and use_apr which can be included with + +:: + + use dim, only::use_apr + use part, only::apr_level,aprmassoftype + +Note that apr_level is integer(kind=1). diff --git a/docs/user-guide/index.rst b/docs/user-guide/index.rst index 4b1e7c182..d9dafe58b 100644 --- a/docs/user-guide/index.rst +++ b/docs/user-guide/index.rst @@ -19,3 +19,4 @@ This section contains the basic user guide for Phantom. hdf5 mpi data-curation + apr_guide diff --git a/src/main/apr.f90 b/src/main/apr.f90 new file mode 100644 index 000000000..192940b0a --- /dev/null +++ b/src/main/apr.f90 @@ -0,0 +1,782 @@ +!--------------------------------------------------------------------------! +! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! +! Copyright (c) 2007-2023 The Authors (see AUTHORS) ! +! See LICENCE file for usage and distribution conditions ! +! http://phantomsph.github.io/ ! +!--------------------------------------------------------------------------! +module apr + ! + ! Contains everything for live adaptive particle refinement + ! + ! :References: None + ! + ! :Owner: Rebecca Nealon + ! + ! :Runtime parameters: + ! - apr_max_in : number of refinement levels (3 -> 2x resolution) + ! - ref_dir : increase (1) or decrease (-1) resolution from the base resolution + ! - apr_type : choice of region, defined in apr_region.f90 + ! + ! :Dependencies: None + ! + implicit none + + public :: init_apr,update_apr,read_options_apr,write_options_apr + public :: create_or_update_apr_clump + integer, public :: apr_max_in = 3, ref_dir = 1, apr_type = 1, apr_max + real, public :: apr_rad = 1.0, apr_drad = 0.1, apr_centre(3) + + private + integer :: top_level = 1, ntrack = 0, track_part = 0 + real, allocatable :: apr_regions(:) + integer, allocatable :: npart_regions(:) + real :: sep_factor = 0.2 + logical :: apr_verbose = .false. + logical :: do_relax = .false. + logical :: adjusted_split = .true. + logical :: directional = .true. + +contains + + !----------------------------------------------------------------------- + !+ + ! Initialising all the apr arrays and properties + !+ + !----------------------------------------------------------------------- + subroutine init_apr(apr_level,ierr) + use dim, only:maxp_hard + use part, only:npart,massoftype,aprmassoftype + use apr_region, only:set_apr_centre,set_apr_regions + integer, intent(inout) :: ierr + integer(kind=1), intent(inout) :: apr_level(:) + logical :: previously_set + integer :: i + + ! the resolution levels are in addition to the base resolution + apr_max = apr_max_in + 1 + + ! if we're reading in a file that already has the levels set, + ! don't override these + previously_set = .false. + if (sum(int(apr_level(1:npart))) > npart) then + previously_set = .true. + do_relax = .false. + endif + + if (.not.previously_set) then + ! initialise the base resolution level + if (ref_dir == 1) then + apr_level(1:npart) = int(1,kind=1) + else + apr_level(1:npart) = int(apr_max,kind=1) + endif + endif + ! initiliase the regions + call set_apr_centre(apr_type,apr_centre,ntrack,track_part) + if (.not.allocated(apr_regions)) allocate(apr_regions(apr_max),npart_regions(apr_max)) + call set_apr_regions(ref_dir,apr_max,apr_regions,apr_rad,apr_drad) + npart_regions = 0 + + ! if we are derefining we make sure that + ! massoftype(igas) is associated with the + ! largest particle + if (ref_dir == -1) then + massoftype(:) = massoftype(:) * 2.**(apr_max -1) + top_level = 1 + else + top_level = apr_max + endif + + ! now set the aprmassoftype array, this stores all the masses for the different resolution levels + do i = 1,apr_max + aprmassoftype(:,i) = massoftype(:)/(2.**(i-1)) + enddo + + ierr = 0 + + if (apr_verbose) print*,'initialised apr' + + end subroutine init_apr + + !----------------------------------------------------------------------- + !+ + ! Subroutine to check if particles need to be split or merged + !+ + !----------------------------------------------------------------------- + subroutine update_apr(npart,xyzh,vxyzu,fxyzu,apr_level) + use dim, only:maxp_hard,ind_timesteps + use part, only:ntot,isdead_or_accreted,igas,aprmassoftype,& + shuffle_part,iphase,iactive,poten,xyzmh_ptmass + use quitdump, only:quit + use relaxem, only:relax_particles + use apr_region, only:dynamic_apr,set_apr_centre + real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fxyzu(:,:) + integer, intent(inout) :: npart + integer(kind=1), intent(inout) :: apr_level(:) + integer :: ii,jj,kk,npartnew,nsplit_total,apri,npartold + integer :: n_ref,nrelax,nmerge,nkilled,apr_current + real, allocatable :: xyzh_ref(:,:),force_ref(:,:),pmass_ref(:) + real, allocatable :: xyzh_merge(:,:),vxyzu_merge(:,:) + integer, allocatable :: relaxlist(:),mergelist(:) + real :: xi,yi,zi,radi,radi_max + + ! if the centre of the region can move, update it + if (dynamic_apr) then + if (ntrack > 0) then + call create_or_update_apr_clump(npart,xyzh,vxyzu,poten,apr_level,& + xyzmh_ptmass,aprmassoftype) + else + call set_apr_centre(apr_type,apr_centre,ntrack,track_part) + endif + endif + + ! If this routine doesn't need to be used, just skip it + if (apr_max == 1) return + + ! Just a metric + if (apr_verbose) print*,'original npart is',npart + + ! Before adjusting the particles, if we're going to + ! relax them then let's save the reference particles + if (do_relax) then + allocate(xyzh_ref(4,maxp_hard),force_ref(3,maxp_hard),pmass_ref(maxp_hard),relaxlist(maxp_hard)) + relaxlist = -1 + + n_ref = 0 + xyzh_ref = 0. + force_ref = 0. + pmass_ref = 0. + + do ii = 1,npart + if (.not.isdead_or_accreted(xyzh(4,ii))) then ! ignore dead particles + n_ref = n_ref + 1 + xyzh_ref(1:4,n_ref) = xyzh(1:4,ii) + pmass_ref(n_ref) = aprmassoftype(igas,apr_level(ii)) + force_ref(1:3,n_ref) = fxyzu(1:3,ii)*pmass_ref(n_ref) + endif + enddo + endif + + ! Do any particles need to be split? + npartnew = npart + npartold = npart + nsplit_total = 0 + nrelax = 0 + apri = 0 ! to avoid compiler errors + + + do jj = 1,apr_max-1 + npartold = npartnew ! to account for new particles as they are being made + + split_over_active: do ii = 1,npartold + + ! only do this on active particles + if (ind_timesteps) then + if (.not.iactive(iphase(ii))) cycle split_over_active + endif + + apr_current = apr_level(ii) + xi = xyzh(1,ii) + yi = xyzh(2,ii) + zi = xyzh(3,ii) + ! this is the refinement level it *should* have based + ! on it's current position + call get_apr((/xi,yi,zi/),apri) + ! if the level it should have is greater than the + ! level it does have, increment it up one + if (apri > apr_current) then + call splitpart(ii,npartnew) + if (do_relax .and. (apri == top_level)) then + nrelax = nrelax + 2 + relaxlist(nrelax-1) = ii + relaxlist(nrelax) = npartnew + endif + nsplit_total = nsplit_total + 1 + endif + enddo split_over_active + enddo + + ! Take into account all the added particles + npart = npartnew + ntot = npartnew + if (apr_verbose) then + print*,'split: ',nsplit_total + print*,'npart: ',npart + endif + + ! Do any particles need to be merged? + allocate(mergelist(npart),xyzh_merge(4,npart),vxyzu_merge(4,npart)) + npart_regions = 0 + do jj = 1,apr_max-1 + kk = apr_max - jj + 1 ! to go from apr_max -> 2 + mergelist = -1 ! initialise + nmerge = 0 + nkilled = 0 + xyzh_merge = 0. + vxyzu_merge = 0. + radi_max = 0. + + merge_over_active: do ii = 1,npart + ! note that here we only do this process for particles that are not already counted in the blending region + if ((apr_level(ii) == kk) .and. (.not.isdead_or_accreted(xyzh(4,ii)))) then ! avoid already dead particles + if (ind_timesteps) then + if (.not.iactive(iphase(ii))) cycle merge_over_active + endif + nmerge = nmerge + 1 + mergelist(nmerge) = ii + xyzh_merge(1:4,nmerge) = xyzh(1:4,ii) + vxyzu_merge(1:3,nmerge) = vxyzu(1:3,ii) + npart_regions(kk) = npart_regions(kk) + 1 + endif + radi = sqrt(dot_product(xyzh(1:3,ii),xyzh(1:3,ii))) + if (radi > radi_max) radi_max = radi + enddo merge_over_active + ! Now send them to be merged + if (nmerge > 1) call merge_with_special_tree(nmerge,mergelist(1:nmerge),xyzh_merge(:,1:nmerge),& + vxyzu_merge(:,1:nmerge),kk,xyzh,vxyzu,apr_level,nkilled,& + nrelax,relaxlist,npartnew) + if (apr_verbose) then + print*,'merged: ',nkilled,kk + print*,'npart: ',npartnew - nkilled + endif + npart_regions(kk) = npart_regions(kk) - nkilled + enddo + ! update npart as required + npart = npartnew + npart_regions(1) = npartnew - sum(npart_regions(2:apr_max)) + if (apr_verbose) print*,'particles at each level:',npart_regions(:) + + ! If we need to relax, do it here + if (nrelax > 0 .and. do_relax) call relax_particles(npart,n_ref,xyzh_ref,force_ref,nrelax,relaxlist) + ! Turn it off now because we only want to do this on first splits + do_relax = .false. + + ! As we may have killed particles, time to do an array shuffle + call shuffle_part(npart) + + ! Tidy up + if (do_relax) then + deallocate(xyzh_ref,force_ref,pmass_ref,relaxlist) + endif + deallocate(mergelist) + + if (apr_verbose) print*,'total particles at end of apr: ',npart + + end subroutine update_apr + + !----------------------------------------------------------------------- + !+ + ! routine to return the adaptive particle refinement level based on position + ! and the boundaries set by the apr_* arrays + !+ + !----------------------------------------------------------------------- + subroutine get_apr(pos,apri) + use io, only:fatal + use apr_region, only:apr_region_is_circle + real, intent(in) :: pos(3) + integer, intent(out) :: apri + integer :: jj, kk + real :: dx,dy,dz,r + + apri = -1 ! to prevent compiler warnings + + do jj = 1,apr_max + if (ref_dir == 1) then + kk = apr_max - jj + 1 ! going from apr_max -> 1 + else + kk = jj ! going from 1 -> apr_max + endif + dx = pos(1) - apr_centre(1) + dy = pos(2) - apr_centre(2) + dz = pos(3) - apr_centre(3) + if (apr_region_is_circle) then + r = sqrt(dx**2 + dy**2) + else + r = sqrt(dx**2 + dy**2 + dz**2) + endif + if (r < apr_regions(kk)) then + apri = kk + return + endif + enddo + + if (apri == -1) call fatal('apr_region, get_apr','could not find apr level') + + end subroutine get_apr + + !----------------------------------------------------------------------- + !+ + ! routine to split one particle into two + !+ + !----------------------------------------------------------------------- + subroutine splitpart(i,npartnew) + use part, only:copy_particle_all,apr_level,xyzh,vxyzu,npartoftype,igas + use part, only:set_particle_type + use physcon, only:pi + use dim, only:ind_timesteps + use random, only:ran2 + use vectorutils, only:cross_product3D,rotatevec + use apr_region, only:apr_region_is_circle + integer, intent(in) :: i + integer, intent(inout) :: npartnew + integer :: j,npartold,next_door + real :: theta,dx,dy,dz,x_add,y_add,z_add,sep,rneigh + real :: v(3),u(3),w(3),a,b,c,mag_v + integer, save :: iseed = 4 + integer(kind=1) :: aprnew + + if (adjusted_split) then + call closest_neigh(i,next_door,rneigh) + sep = min(sep_factor*xyzh(4,i),0.35*rneigh) + sep = sep/xyzh(4,i) ! for consistency later on + else + sep = sep_factor + endif + + ! Calculate the plane that the particle must be split along + ! to be tangential to the splitting region. Particles are split + ! on this plane but rotated randomly on it. + dx = xyzh(1,i) - apr_centre(1) + dy = xyzh(2,i) - apr_centre(2) + if (.not.apr_region_is_circle) then + dz = xyzh(3,i) - apr_centre(3) + + ! Calculate a vector, v, that lies on the plane + u = (/1.0,0.5,1.0/) + w = (/dx,dy,dz/) + call cross_product3D(u,w,v) + + ! rotate it around the normal to the plane by a random amount + theta = ran2(iseed)*2.*pi + call rotatevec(v,w,theta) + + if (.not.directional) then + ! No directional splitting, so just create a unit vector in a random direction + a = ran2(iseed) - 0.5 + b = ran2(iseed) - 0.5 + c = ran2(iseed) - 0.5 + v = (/a, b, c/) + endif + + mag_v = sqrt(dot_product(v,v)) + if (mag_v > tiny(mag_v)) then + v = v/mag_v + else + v = 0. + endif + else + dz = 0. + u = 0. + w = 0. + v = 0. + theta = atan2(dy,dx) + 0.5*pi + v(1) = cos(theta) + v(2) = sin(theta) + endif + + ! Now apply it + x_add = sep*v(1)*xyzh(4,i) + y_add = sep*v(2)*xyzh(4,i) + z_add = sep*v(3)*xyzh(4,i) + + npartold = npartnew + npartnew = npartold + 1 + npartoftype(igas) = npartoftype(igas) + 1 + aprnew = apr_level(i) + int(1,kind=1) ! to prevent compiler warnings + + !--create the new particle + do j=npartold+1,npartnew + call copy_particle_all(i,j,new_part=.true.) + xyzh(1,j) = xyzh(1,i) + x_add + xyzh(2,j) = xyzh(2,i) + y_add + xyzh(3,j) = xyzh(3,i) + z_add + vxyzu(:,j) = vxyzu(:,i) + xyzh(4,j) = xyzh(4,i)*(0.5**(1./3.)) + apr_level(j) = aprnew + if (ind_timesteps) call put_in_smallest_bin(j) + enddo + + ! Edit the old particle that was sent in and kept + xyzh(1,i) = xyzh(1,i) - x_add + xyzh(2,i) = xyzh(2,i) - y_add + xyzh(3,i) = xyzh(3,i) - z_add + apr_level(i) = aprnew + xyzh(4,i) = xyzh(4,i)*(0.5**(1./3.)) + if (ind_timesteps) call put_in_smallest_bin(i) + + end subroutine splitpart + + !----------------------------------------------------------------------- + !+ + ! Take in all particles that *might* be merged at this apr_level + ! and use our special tree to merge what has left the region + !+ + !----------------------------------------------------------------------- + subroutine merge_with_special_tree(nmerge,mergelist,xyzh_merge,vxyzu_merge,current_apr,& + xyzh,vxyzu,apr_level,nkilled,nrelax,relaxlist,npartnew) + use linklist, only:set_linklist,ncells,ifirstincell,get_cell_location + use mpiforce, only:cellforce + use kdtree, only:inodeparts,inoderange + use part, only:kill_particle,npartoftype + use dim, only:ind_timesteps + integer, intent(inout) :: nmerge,nkilled,nrelax,relaxlist(:),npartnew + integer(kind=1), intent(inout) :: apr_level(:) + integer, intent(in) :: current_apr,mergelist(:) + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + real, intent(inout) :: xyzh_merge(:,:),vxyzu_merge(:,:) + integer :: remainder,icell,i,n_cell,apri,m + integer :: eldest,tuther + real :: com(3) + type(cellforce) :: cell + + ! First ensure that we're only sending in a multiple of 2 to the tree + remainder = modulo(nmerge,2) + nmerge = nmerge - remainder + + call set_linklist(nmerge,nmerge,xyzh_merge(:,1:nmerge),vxyzu_merge(:,1:nmerge),& + for_apr=.true.) + ! Now use the centre of mass of each cell to check whether it should + ! be merged or not + com = 0. + over_cells: do icell=1,int(ncells) + i = ifirstincell(icell) + if (i == 0) cycle over_cells !--skip empty cells + n_cell = inoderange(2,icell)-inoderange(1,icell)+1 + + call get_cell_location(icell,cell%xpos,cell%xsizei,cell%rcuti) + com(1) = cell%xpos(1) + com(2) = cell%xpos(2) + com(3) = cell%xpos(3) + call get_apr(com(1:3),apri) + + ! If the apr level based on the com is lower than the current level, + ! we merge! + if (apri < current_apr) then + eldest = mergelist(inodeparts(inoderange(1,icell))) + tuther = mergelist(inodeparts(inoderange(1,icell) + 1)) !as in kdtree + + ! keep eldest, reassign it to have the com properties + xyzh(1,eldest) = cell%xpos(1) + xyzh(2,eldest) = cell%xpos(2) + xyzh(3,eldest) = cell%xpos(3) + vxyzu(1:3,eldest) = 0.5*(vxyzu(1:3,eldest) + vxyzu(1:3,tuther)) + + xyzh(4,eldest) = (0.5*(xyzh(4,eldest) + xyzh(4,tuther)))*(2.0**(1./3.)) + apr_level(eldest) = apr_level(eldest) - int(1,kind=1) + if (ind_timesteps) call put_in_smallest_bin(eldest) + + ! add it to the shuffling list if needed + if (do_relax) then + nrelax = nrelax + 1 + relaxlist(nrelax) = eldest + endif + + ! discard tuther (t'other) + call kill_particle(tuther,npartoftype) + nkilled = nkilled + 2 ! this refers to the number of children killed + ! If this particle was on the shuffle list previously, take it off + do m = 1,nrelax + if (relaxlist(m) == tuther) relaxlist(m) = 0 + enddo + endif + + enddo over_cells + + end subroutine merge_with_special_tree + + !----------------------------------------------------------------------- + !+ + ! reads input options from the input file + !+ + !----------------------------------------------------------------------- + subroutine read_options_apr(name,valstring,imatch,igotall,ierr) + use io, only:fatal + character(len=*), intent(in) :: name,valstring + logical, intent(out) :: imatch,igotall + integer, intent(out) :: ierr + integer, save :: ngot = 0 + character(len=30), parameter :: label = 'read_options_apr' + + imatch = .true. + select case(trim(name)) + case('apr_max') + read(valstring,*,iostat=ierr) apr_max_in + ngot = ngot + 1 + if (apr_max_in < 0) call fatal(label,'apr_max < 0 in input options') + case('ref_dir') + read(valstring,*,iostat=ierr) ref_dir + ngot = ngot + 1 + case('apr_type') + read(valstring,*,iostat=ierr) apr_type + ngot = ngot + 1 + case('apr_rad') + read(valstring,*,iostat=ierr) apr_rad + ngot = ngot + 1 + if (apr_rad < tiny(apr_rad)) call fatal(label,'apr_rad too small in input options') + case('apr_drad') + read(valstring,*,iostat=ierr) apr_drad + ngot = ngot + 1 + if (apr_drad < tiny(apr_drad)) call fatal(label,'apr_drad too small in input options') + case default + imatch = .false. + select case(apr_type) + case(1) + call read_options_apr1(name,valstring,imatch,igotall,ierr) + case(2) + call read_options_apr2(name,valstring,imatch,igotall,ierr) + end select + end select + + igotall = (ngot == 5) + end subroutine read_options_apr + + !----------------------------------------------------------------------- + !+ + ! extra subroutines for reading in different styles of apr zones + !+ + !----------------------------------------------------------------------- + + subroutine read_options_apr1(name,valstring,imatch,igotall,ierr) + use io, only:fatal + character(len=*), intent(in) :: name,valstring + logical, intent(out) :: imatch,igotall + integer, intent(out) :: ierr + integer, save :: ngot = 0 + character(len=30), parameter :: label = 'read_options_apr1' + + imatch = .true. + select case(trim(name)) + case('apr_centre(1)') + read(valstring,*,iostat=ierr) apr_centre(1) + ngot = ngot + 1 + case('apr_centre(2)') + read(valstring,*,iostat=ierr) apr_centre(2) + ngot = ngot + 1 + case('apr_centre(3)') + read(valstring,*,iostat=ierr) apr_centre(3) + ngot = ngot + 1 + case default + imatch = .false. + end select + + end subroutine read_options_apr1 + + subroutine read_options_apr2(name,valstring,imatch,igotall,ierr) + use io, only:fatal + character(len=*), intent(in) :: name,valstring + logical, intent(out) :: imatch,igotall + integer, intent(out) :: ierr + integer, save :: ngot = 0 + character(len=30), parameter :: label = 'read_options_apr2' + + imatch = .true. + select case(trim(name)) + case('track_part') + read(valstring,*,iostat=ierr) track_part + ngot = ngot + 1 + if (track_part < 1) call fatal(label,'track_part not chosen in input options') + case default + imatch = .false. + end select + + end subroutine read_options_apr2 + + !----------------------------------------------------------------------- + !+ + ! Writes input options to the input file. + !+ + !----------------------------------------------------------------------- + subroutine write_options_apr(iunit) + use infile_utils, only:write_inopt + integer, intent(in) :: iunit + + call write_inopt(apr_max_in,'apr_max','number of additional refinement levels (3 -> 2x resolution)',iunit) + call write_inopt(ref_dir,'ref_dir','increase (1) or decrease (-1) resolution',iunit) + call write_inopt(apr_type,'apr_type','1: static, 2: moving sink, 3: create clumps',iunit) + select case (apr_type) + + case(2) + call write_inopt(track_part,'track_part','number of sink to track',iunit) + + case default + call write_inopt(apr_centre(1),'apr_centre(1)','centre of region x position',iunit) + call write_inopt(apr_centre(2),'apr_centre(2)','centre of region y position',iunit) + call write_inopt(apr_centre(3),'apr_centre(3)','centre of region z position',iunit) + + end select + call write_inopt(apr_rad,'apr_rad','radius of innermost region',iunit) + call write_inopt(apr_drad,'apr_drad','size of step to next region',iunit) + + end subroutine write_options_apr + + subroutine closest_neigh(i,next_door,rmin) + use part, only:xyzh,npart + integer, intent(in) :: i + integer, intent(out) :: next_door + real, intent(out) :: rmin + real :: dx,dy,dz,rtest + integer :: j + + rmin = huge(rmin) + next_door = 0 + do j = 1,npart + if (j == i) cycle + dx = xyzh(1,i) - xyzh(1,j) + dy = xyzh(2,i) - xyzh(2,j) + dz = xyzh(3,i) - xyzh(3,j) + rtest = dx**2 + dy**2 + dz**2 + if (rtest < rmin) then + next_door = j + rmin = rtest + endif + enddo + + rmin = sqrt(rmin) + + end subroutine closest_neigh + + !----------------------------------------------------------------------- + !+ + ! routine to put a particle on the shortest timestep + !+ + !----------------------------------------------------------------------- + subroutine put_in_smallest_bin(i) + use timestep_ind, only:nbinmax + use part, only:ibin + integer, intent(in) :: i + + ibin(i) = nbinmax + + end subroutine put_in_smallest_bin + + !----------------------------------------------------------------------- + !+ + ! Create a new apr region that is centred on a dense clump + ! (This is work in progress) + !+ + !----------------------------------------------------------------------- + + subroutine create_or_update_apr_clump(npart,xyzh,vxyzu,poten,apr_level,xyzmh_ptmass,aprmassoftype) + use apr_region, only:set_apr_centre + use part, only:igas,rhoh + use ptmass, only:rho_crit_cgs + integer, intent(in) :: npart + integer(kind=1), intent(in) :: apr_level(:) + real, intent(in) :: xyzh(:,:), vxyzu(:,:), aprmassoftype(:,:),xyzmh_ptmass(:,:) + real(kind=4), intent(in) :: poten(:) + integer :: nbins, ii, ibin, nmins, jj, apri + integer, allocatable :: counter(:), minima(:), min_particle(:) + real, allocatable :: radius(:), ave_poten(:) + real :: rin, rout, dbin, dx, dy, dz, rad, gradleft, gradright + real :: minpoten, pmassi, rhoi + + ! set up arrays + nbins = 100 + allocate(counter(nbins),radius(nbins),ave_poten(nbins),& + minima(nbins),min_particle(nbins)) + + ! Currently hardwired but this is problematic + rin = 10. + rout = 100. + dbin = (rout-rin)/real(nbins-1) + do ii = 1,nbins + radius(ii) = rin + real(ii-1)*dbin + enddo + + ave_poten = 0. + counter = 0 + ! Create an azimuthally averaged potential energy vs. radius profile + do ii = 1,npart + dx = xyzh(1,ii) - xyzmh_ptmass(1,1) + dy = xyzh(2,ii) - xyzmh_ptmass(2,1) + dz = xyzh(3,ii) - xyzmh_ptmass(3,1) + rad = sqrt(dx**2 + dy**2 + dz**2) + pmassi = aprmassoftype(igas,apr_level(ii)) + + ibin = int((rad - radius(1))/dbin + 1) + if ((ibin > nbins) .or. (ibin < 1)) cycle + + ave_poten(ibin) = ave_poten(ibin) + poten(ii)/pmassi + counter(ibin) = counter(ibin) + 1 + enddo + + ! average with the number of particles in the bin + do ii = 1,nbins + if (counter(ii) > 0) then + ave_poten(ii) = ave_poten(ii)/counter(ii) + else + ave_poten(ii) = 0. + endif + enddo + + ! Identify what radius the local minima are at + minima = 0 + nmins = 0 + do ii = 2, nbins-1 + gradleft = (ave_poten(ii) - ave_poten(ii-1))/(radius(ii) - radius(ii-1)) + gradright = (ave_poten(ii+1) - ave_poten(ii))/(radius(ii+1) - radius(ii)) + if (gradleft * gradright < 0.) then + nmins = nmins + 1 + minima(nmins) = ii + endif + enddo + if (nmins == 0) return + + ! Identify the particles in these minima that have the lowest potential energy + ! this is quite inefficient, in future should save these above into the bins so + ! you just need to cycle through the subset? Don't know if this is faster + minpoten = 1.0 + do jj = 1,nmins + do ii = 1,npart + dx = xyzh(1,ii) - xyzmh_ptmass(1,1) + dy = xyzh(2,ii) - xyzmh_ptmass(2,1) + dz = xyzh(3,ii) - xyzmh_ptmass(3,1) + rad = sqrt(dx**2 + dy**2 + dz**2) + pmassi = aprmassoftype(igas,apr_level(ii)) + + ibin = int((rad - radius(1))/dbin + 1) + if ((ibin == (minima(jj))) .or. & + (ibin - 1 == (minima(jj))) .or. & + (ibin + 1 == (minima(jj)))) then + if((poten(ii)/pmassi) < minpoten) then + minpoten = poten(ii)/pmassi + min_particle(jj) = ii + endif + endif + enddo + enddo + + ! For the moment, force there to only be one minimum + ! and let it be the lowest + nmins = 1 + + ! Check they are not already within a region of low potential energy + ! If they are, replace the existing particle as the one to be tracked + over_mins: do jj = 1,nmins + ii = min_particle(jj) + ! check that the particle at the lowest potential energy has also met the + ! density criteria + pmassi = aprmassoftype(igas,apr_level(ii)) + rhoi = rhoh(xyzh(4,ii),pmassi) + if (rhoi < rho_crit_cgs) cycle over_mins + + ! get the refinement level of the particle in the middle of the potential + call get_apr(xyzh(1:3,ii),apri) + if ((ref_dir == -1) .and. (apri == apr_max) .and. (ntrack<1)) then + ! it's a newly identified clump, time to derefine it + ntrack = ntrack + 1 + track_part = ii + else + ! it's an existing clump, update the position of it's centre + track_part = ii + endif + enddo over_mins + if (ntrack > 0) call set_apr_centre(apr_type,apr_centre,ntrack,track_part) + print*,'tracking ',track_part,ntrack + + ! tidy up + deallocate(counter,ave_poten,radius,minima,min_particle) + + end subroutine + +end module apr diff --git a/src/main/apr_region.f90 b/src/main/apr_region.f90 new file mode 100644 index 000000000..9ae45ffeb --- /dev/null +++ b/src/main/apr_region.f90 @@ -0,0 +1,102 @@ +!--------------------------------------------------------------------------! +! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! +! Copyright (c) 2007-2023 The Authors (see AUTHORS) ! +! See LICENCE file for usage and distribution conditions ! +! http://phantomsph.github.io/ ! +!--------------------------------------------------------------------------! +module apr_region + ! + ! Contains everything for setting the adaptive particle refinement regions + ! + ! :References: None + ! + ! :Owner: Rebecca Nealon + ! + ! :Runtime parameters: + ! - apr_max_in : number of refinement levels (3 -> 2x resolution) + ! - ref_dir : increase (1) or decrease (-1) resolution from the base resolution + ! - [x,y,z]_centre : centre coordinates of the region to be more highly resolved + ! - apr_rad : radius of the region to be more highly resolved + ! + ! :Dependencies: None + ! + implicit none + + logical, public :: dynamic_apr = .false., apr_region_is_circle = .false. + public :: set_apr_centre, set_apr_regions + + private + +contains + + !----------------------------------------------------------------------- + !+ + ! Setting/updating the centre of the apr region (as it may move) + !+ + !----------------------------------------------------------------------- + +subroutine set_apr_centre(apr_type,apr_centre,ntrack,track_part) + use part, only: xyzmh_ptmass,xyzh + integer, intent(in) :: apr_type + real, intent(out) :: apr_centre(3) + integer, optional, intent(in) :: ntrack,track_part + + select case (apr_type) + + case(1) ! a static circle + ! do nothing here + + case(2) ! around sink particle named track_part + dynamic_apr = .true. + apr_centre(1) = xyzmh_ptmass(1,track_part) + apr_centre(2) = xyzmh_ptmass(2,track_part) + apr_centre(3) = xyzmh_ptmass(3,track_part) + + case(3) ! to derefine a clump - only activated when the centre of the clump + ! has been found + dynamic_apr = .true. + if (present(ntrack)) then + apr_centre(1) = xyzh(1,track_part) + apr_centre(2) = xyzh(2,track_part) + apr_centre(3) = xyzh(3,track_part) + else + apr_centre = tiny(apr_centre) ! this *might* be safe? Just want it to be irrelevant + endif + + case default ! used for the test suite + apr_centre(:) = 0. + + end select + +end subroutine set_apr_centre + +!----------------------------------------------------------------------- +!+ +! Initialising all the apr region arrays that decide +! the spatial arrangement of the regions +!+ +!----------------------------------------------------------------------- + +subroutine set_apr_regions(ref_dir,apr_max,apr_regions,apr_rad,apr_drad) + integer, intent(in) :: ref_dir,apr_max + real, intent(in) :: apr_rad,apr_drad + real, intent(inout) :: apr_regions(apr_max) + integer :: ii,kk + + if (ref_dir == 1) then + apr_regions(1) = huge(apr_regions(1)) ! this needs to be a number that encompasses the whole domain + do ii = 2,apr_max + kk = apr_max - ii + 2 + apr_regions(kk) = apr_rad + (ii-1)*apr_drad + enddo + else + apr_regions(apr_max) = huge(apr_regions(apr_max)) ! again this just needs to encompass the whole domain + do ii = 1,apr_max-1 + apr_regions(ii) = apr_rad + (ii-1)*apr_drad + enddo + endif + +end subroutine set_apr_regions + + +end module apr_region diff --git a/src/main/centreofmass.f90 b/src/main/centreofmass.f90 index 88fb0fb70..debb0efec 100644 --- a/src/main/centreofmass.f90 +++ b/src/main/centreofmass.f90 @@ -74,8 +74,9 @@ end subroutine reset_centreofmass !---------------------------------------------------------------- subroutine get_centreofmass(xcom,vcom,npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz_ptmass,mass) use io, only:id,master - use dim, only:maxphase,maxp - use part, only:massoftype,iamtype,iphase,igas,isdead_or_accreted + use dim, only:maxphase,maxp,use_apr + use part, only:massoftype,iamtype,iphase,igas,isdead_or_accreted, & + aprmassoftype,apr_level use mpiutils, only:reduceall_mpi real, intent(out) :: xcom(3),vcom(3) integer, intent(in) :: npart @@ -97,7 +98,7 @@ subroutine get_centreofmass(xcom,vcom,npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz totmass = 0.d0 pmassi = massoftype(igas) !$omp parallel default(none) & -!$omp shared(maxphase,maxp) & +!$omp shared(maxphase,maxp,aprmassoftype,apr_level) & !$omp shared(npart,xyzh,vxyzu,iphase,massoftype) & !$omp private(i,itype,xi,yi,zi,hi) & !$omp firstprivate(pmassi) & @@ -112,9 +113,17 @@ subroutine get_centreofmass(xcom,vcom,npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz if (maxphase==maxp) then itype = iamtype(iphase(i)) if (itype > 0) then ! avoid problems if called from ICs - pmassi = massoftype(itype) + if (use_apr) then + pmassi = aprmassoftype(itype,apr_level(i)) + else + pmassi = massoftype(itype) + endif else - pmassi = massoftype(igas) + if (use_apr) then + pmassi = aprmassoftype(igas,apr_level(i)) + else + pmassi = massoftype(igas) + endif endif endif totmass = totmass + pmassi @@ -168,8 +177,9 @@ end subroutine get_centreofmass !---------------------------------------------------------------- subroutine get_centreofmass_accel(acom,npart,xyzh,fxyzu,fext,nptmass,xyzmh_ptmass,fxyz_ptmass) use io, only:id,master - use dim, only:maxphase,maxp - use part, only:massoftype,iamtype,iphase,igas,isdead_or_accreted + use dim, only:maxphase,maxp,use_apr + use part, only:massoftype,iamtype,iphase,igas,isdead_or_accreted, & + apr_level,aprmassoftype use mpiutils, only:reduceall_mpi real, intent(out) :: acom(3) integer, intent(in) :: npart @@ -188,6 +198,7 @@ subroutine get_centreofmass_accel(acom,npart,xyzh,fxyzu,fext,nptmass,xyzmh_ptmas !$omp shared(maxphase,maxp,id) & !$omp shared(xyzh,fxyzu,fext,npart) & !$omp shared(massoftype,iphase,nptmass) & +!$omp shared(aprmassoftype,apr_level) & !$omp shared(xyzmh_ptmass,fxyz_ptmass) & !$omp private(i,pmassi,hi) & !$omp reduction(+:acom) & @@ -197,9 +208,17 @@ subroutine get_centreofmass_accel(acom,npart,xyzh,fxyzu,fext,nptmass,xyzmh_ptmas hi = xyzh(4,i) if (.not.isdead_or_accreted(hi)) then if (maxphase==maxp) then - pmassi = massoftype(iamtype(iphase(i))) + if (use_apr) then + pmassi = aprmassoftype(iamtype(iphase(i)),apr_level(i)) + else + pmassi = massoftype(iamtype(iphase(i))) + endif else - pmassi = massoftype(igas) + if (use_apr) then + pmassi = aprmassoftype(igas,apr_level(i)) + else + pmassi = massoftype(igas) + endif endif totmass = totmass + pmassi acom(1) = acom(1) + pmassi*(fxyzu(1,i) + fext(1,i)) @@ -244,10 +263,10 @@ end subroutine get_centreofmass_accel !+ !---------------------------------------------------------------- subroutine correct_bulk_motion() - use dim, only:maxp,maxphase + use dim, only:maxp,maxphase,use_apr use part, only:npart,xyzh,vxyzu,fxyzu,iamtype,igas,iphase,& nptmass,xyzmh_ptmass,vxyz_ptmass,isdead_or_accreted,& - massoftype + massoftype,aprmassoftype,apr_level use mpiutils, only:reduceall_mpi use io, only:iprint,iverbose,id,master real :: totmass,pmassi,hi,xmom,ymom,zmom @@ -266,6 +285,7 @@ subroutine correct_bulk_motion() !$omp shared(maxphase,maxp) & !$omp shared(xyzh,vxyzu,fxyzu,npart) & !$omp shared(massoftype,iphase) & +!$omp shared(aprmassoftype,apr_level) & !$omp shared(xyzmh_ptmass,vxyz_ptmass,nptmass) & !$omp private(i,hi) & !$omp firstprivate(pmassi) & @@ -276,9 +296,17 @@ subroutine correct_bulk_motion() hi = xyzh(4,i) if (.not.isdead_or_accreted(hi)) then if (maxphase==maxp) then - pmassi = massoftype(iamtype(iphase(i))) + if (use_apr) then + pmassi = aprmassoftype(iamtype(iphase(i)),apr_level(i)) + else + pmassi = massoftype(iamtype(iphase(i))) + endif else - pmassi = massoftype(igas) + if (use_apr) then + pmassi = aprmassoftype(igas,apr_level(i)) + else + pmassi = massoftype(igas) + endif endif totmass = totmass + pmassi @@ -362,8 +390,10 @@ end subroutine correct_bulk_motion !------------------------------------------------------------------------ subroutine get_total_angular_momentum(xyzh,vxyz,npart,L_tot,xyzmh_ptmass,vxyz_ptmass,npart_ptmass) use vectorutils, only:cross_product3D - use part, only:iphase,iamtype,massoftype,isdead_or_accreted + use part, only:iphase,iamtype,massoftype,isdead_or_accreted, & + aprmassoftype,apr_level use mpiutils, only:reduceall_mpi + use dim, only:use_apr real, intent(in) :: xyzh(:,:),vxyz(:,:) real, optional, intent(in):: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) integer, intent(in) :: npart @@ -379,6 +409,7 @@ subroutine get_total_angular_momentum(xyzh,vxyz,npart,L_tot,xyzmh_ptmass,vxyz_pt !$omp parallel default(none) & !$omp shared(xyzh,vxyz,npart) & !$omp shared(massoftype,iphase) & +!$omp shared(aprmassoftype,apr_level) & !$omp shared(xyzmh_ptmass,vxyz_ptmass,npart_ptmass) & !$omp private(ii,itype,pmassi,temp) & !$omp reduction(+:L_tot) @@ -386,7 +417,11 @@ subroutine get_total_angular_momentum(xyzh,vxyz,npart,L_tot,xyzmh_ptmass,vxyz_pt do ii = 1,npart if (.not.isdead_or_accreted(xyzh(4,ii))) then itype = iamtype(iphase(ii)) - pmassi = massoftype(itype) + if (use_apr) then + pmassi = aprmassoftype(itype,apr_level(ii)) + else + pmassi = massoftype(itype) + endif call cross_product3D(xyzh(1:3,ii),vxyz(1:3,ii),temp) L_tot = L_tot + temp*pmassi endif diff --git a/src/main/checkconserved.f90 b/src/main/checkconserved.f90 index 9fb43c454..4def126fc 100644 --- a/src/main/checkconserved.f90 +++ b/src/main/checkconserved.f90 @@ -17,10 +17,10 @@ module checkconserved ! ! :Dependencies: boundary_dyn, dim, externalforces, io, options, part ! - use dim, only:maxdusttypes + use dim, only:maxdusttypes,use_apr implicit none real, public :: get_conserv = 1.0 ! to track when we have initial values for conservation laws - real, public :: etot_in,angtot_in,totmom_in,mdust_in(maxdusttypes) + real, public :: etot_in,angtot_in,totmom_in,mdust_in(maxdusttypes),mtot_in public :: init_conservation_checks, check_conservation_error public :: check_magnetic_stability @@ -36,14 +36,16 @@ module checkconserved !+ !---------------------------------------------------------------- subroutine init_conservation_checks(should_conserve_energy,should_conserve_momentum,& - should_conserve_angmom,should_conserve_dustmass) + should_conserve_angmom,should_conserve_dustmass,& + should_conserve_aprmass) use options, only:icooling,ieos,ipdv_heating,ishock_heating,& iresistive_heating,use_dustfrac,iexternalforce - use dim, only:mhd,maxvxyzu,periodic,inject_parts + use dim, only:mhd,maxvxyzu,periodic,inject_parts,use_apr use part, only:iboundary,npartoftype use boundary_dyn,only:dynamic_bdy logical, intent(out) :: should_conserve_energy,should_conserve_momentum logical, intent(out) :: should_conserve_angmom,should_conserve_dustmass + logical, intent(out) :: should_conserve_aprmass ! ! should conserve energy if using adiabatic equation of state with no cooling @@ -73,12 +75,16 @@ subroutine init_conservation_checks(should_conserve_energy,should_conserve_momen ! ! Each injection routine will need to bookeep conserved quantities, but until then... ! - if (inject_parts .or. dynamic_bdy) then + if (inject_parts .or. dynamic_bdy .or. use_apr) then should_conserve_energy = .false. should_conserve_momentum = .false. should_conserve_angmom = .false. endif + ! This is to check that total mass is conserved when we use apr + ! It can't be used if mass is accreted or injected + should_conserve_aprmass = (iexternalforce==0 .and. use_apr .and. .not.inject_parts) + end subroutine init_conservation_checks !---------------------------------------------------------------- diff --git a/src/main/checksetup.f90 b/src/main/checksetup.f90 index 61827b35b..b7bcc4e3b 100644 --- a/src/main/checksetup.f90 +++ b/src/main/checksetup.f90 @@ -917,7 +917,8 @@ end subroutine check_gr !------------------------------------------------------------------ subroutine check_for_identical_positions(npart,xyzh,nbad) use sortutils, only:indexxfunc,r2func - use part, only:maxphase,maxp,iphase,igas,iamtype,isdead_or_accreted + use part, only:maxphase,maxp,iphase,igas,iamtype,isdead_or_accreted,& + apr_level integer, intent(in) :: npart real, intent(in) :: xyzh(:,:) integer, intent(out) :: nbad @@ -937,7 +938,7 @@ subroutine check_for_identical_positions(npart,xyzh,nbad) itypei = igas itypej = igas !$omp parallel do default(none) & - !$omp shared(npart,xyzh,index,maxphase,maxp,iphase) & + !$omp shared(npart,xyzh,index,maxphase,maxp,iphase,apr_level) & !$omp firstprivate(itypei,itypej) & !$omp private(i,j,dx,dx2) & !$omp reduction(+:nbad) @@ -955,8 +956,8 @@ subroutine check_for_identical_positions(npart,xyzh,nbad) nbad = nbad + 1 if (nbad <= 10) then print*,'WARNING: particles of same type at same position: ' - print*,' ',index(i),':',xyzh(1:3,index(i)) - print*,' ',index(j),':',xyzh(1:3,index(j)) + print*,' ',index(i),':',xyzh(1:3,index(i)),apr_level(i) + print*,' ',index(j),':',xyzh(1:3,index(j)),apr_level(j) endif endif j = j + 1 diff --git a/src/main/config.F90 b/src/main/config.F90 index 97b13a132..f33c52aea 100644 --- a/src/main/config.F90 +++ b/src/main/config.F90 @@ -326,6 +326,17 @@ module dim logical, parameter :: inject_parts = .false. #endif +!-------------------- +! Adaptive Particle Refinement (APR) +!-------------------- +#ifdef APR + logical, parameter :: use_apr = .true. + integer, parameter :: apr_maxhard = 10 +#else + logical, parameter :: use_apr = .false. + integer, parameter :: apr_maxhard = 0 +#endif + !-------------------- ! individual timesteps !-------------------- @@ -362,6 +373,7 @@ subroutine update_max_sizes(n,ntot) integer(kind=8), optional, intent(in) :: ntot maxp = n + if (use_apr) maxp = 4*n if (use_krome) maxp_krome = maxp diff --git a/src/main/cons2prim.f90 b/src/main/cons2prim.f90 index d3a6a507e..e560b8f7b 100644 --- a/src/main/cons2prim.f90 +++ b/src/main/cons2prim.f90 @@ -140,29 +140,36 @@ end subroutine prim2consi subroutine cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) use cons2primsolver, only:conservative2primitive use part, only:isdead_or_accreted,massoftype,igas,rhoh,igasP,ics,ien_type,& - itemp,igamma + itemp,igamma,aprmassoftype,apr_level use io, only:fatal use eos, only:ieos,done_init_eos,init_eos,get_spsound + use dim, only:use_apr + use eos, only:ieos,done_init_eos,init_eos,get_spsound integer, intent(in) :: npart real, intent(in) :: pxyzu(:,:),xyzh(:,:),metrics(:,:,:,:) real, intent(inout) :: vxyzu(:,:),dens(:) real, intent(out) :: eos_vars(:,:) integer :: i, ierr - real :: p_guess,rhoi,tempi,gammai + real :: p_guess,rhoi,tempi,gammai,pmassi if (.not.done_init_eos) call init_eos(ieos,ierr) !$omp parallel do default (none) & -!$omp shared(xyzh,metrics,vxyzu,dens,pxyzu,npart,massoftype) & -!$omp shared(ieos,eos_vars,ien_type) & -!$omp private(i,ierr,p_guess,rhoi,tempi,gammai) +!$omp shared(xyzh,metrics,vxyzu,dens,pxyzu,npart,massoftype,aprmassoftype) & +!$omp shared(ieos,eos_vars,ien_type,apr_level) & +!$omp private(i,ierr,p_guess,rhoi,tempi,gammai,pmassi) do i=1,npart if (.not.isdead_or_accreted(xyzh(4,i))) then ! get pressure, temperature and gamma from previous step as the initial guess p_guess = eos_vars(igasP,i) tempi = eos_vars(itemp,i) gammai = eos_vars(igamma,i) - rhoi = rhoh(xyzh(4,i),massoftype(igas)) + if (use_apr) then + pmassi = aprmassoftype(igas,apr_level(i)) + else + pmassi = massoftype(igas) + endif + rhoi = rhoh(xyzh(4,i),pmassi) call conservative2primitive(xyzh(1:3,i),metrics(:,:,:,i),vxyzu(1:3,i),dens(i),vxyzu(4,i), & p_guess,tempi,gammai,rhoi,pxyzu(1:3,i),pxyzu(4,i),ierr,ien_type) @@ -197,12 +204,12 @@ subroutine cons2prim_everything(npart,xyzh,vxyzu,dvdx,rad,eos_vars,radprop,& Bevol,Bxyz,dustevol,dustfrac,alphaind) use part, only:isdead_or_accreted,massoftype,igas,rhoh,igasP,iradP,iradxi,ics,imu,iX,iZ,& iohm,ihall,nden_nimhd,eta_nimhd,iambi,get_partinfo,iphase,this_is_a_test,& - ndustsmall,itemp,ikappa,idmu,idgamma,icv,isionised + ndustsmall,itemp,ikappa,idmu,idgamma,icv,aprmassoftype,apr_level,isionised use part, only:nucleation,igamma use eos, only:equationofstate,ieos,eos_outputs_mu,done_init_eos,init_eos,gmw,X_in,Z_in,gamma use radiation_utils, only:radiation_equation_of_state,get_opacity use dim, only:mhd,maxvxyzu,maxphase,maxp,use_dustgrowth,& - do_radiation,nalpha,mhd_nonideal,do_nucleation,use_krome,update_muGamma + do_radiation,nalpha,mhd_nonideal,do_nucleation,use_krome,update_muGamma,use_apr use nicil, only:nicil_update_nimhd,nicil_translate_error,n_warn use io, only:fatal,real4,warning use cullendehnen, only:get_alphaloc,xi_limiter @@ -235,9 +242,9 @@ subroutine cons2prim_everything(npart,xyzh,vxyzu,dvdx,rad,eos_vars,radprop,& Z_i = Z_in !$omp parallel do default (none) & -!$omp shared(xyzh,vxyzu,npart,rad,eos_vars,radprop,Bevol,Bxyz) & +!$omp shared(xyzh,vxyzu,npart,rad,eos_vars,radprop,Bevol,Bxyz,apr_level) & !$omp shared(ieos,nucleation,nden_nimhd,eta_nimhd) & -!$omp shared(alpha,alphamax,iphase,maxphase,maxp,massoftype,isionised) & +!$omp shared(alpha,alphamax,iphase,maxphase,maxp,massoftype,aprmassoftype,isionised) & !$omp shared(use_dustfrac,dustfrac,dustevol,this_is_a_test,ndustsmall,alphaind,dvdx) & !$omp shared(iopacity_type,use_var_comp,do_nucleation,update_muGamma,implicit_radiation) & !$omp private(i,spsound,rhoi,p_on_rhogas,rhogas,gasfrac,uui) & @@ -257,7 +264,11 @@ subroutine cons2prim_everything(npart,xyzh,vxyzu,dvdx,rad,eos_vars,radprop,& if (maxphase==maxp) call get_partinfo(iphase(i),iactivei,iamgasi,iamdusti,iamtypei) - pmassi = massoftype(iamtypei) + if (use_apr) then + pmassi = aprmassoftype(iamtypei,apr_level(i)) + else + pmassi = massoftype(iamtypei) + endif rhoi = rhoh(hi,pmassi) ! !--Convert dust variable to dustfrac @@ -294,7 +305,10 @@ subroutine cons2prim_everything(npart,xyzh,vxyzu,dvdx,rad,eos_vars,radprop,& if (use_krome) gammai = eos_vars(igamma,i) if (maxvxyzu >= 4) then uui = vxyzu(4,i) - if (uui < 0.) call warning('cons2prim','Internal energy < 0',i,'u',uui) + if (uui < 0.) then + call warning('cons2prim','Internal energy < 0',i,'u',uui) + print*,'apr',apr_level(i) + endif call equationofstate(ieos,p_on_rhogas,spsound,rhogas,xi,yi,zi,temperaturei,eni=uui,& gamma_local=gammai,mu_local=mui,Xlocal=X_i,Zlocal=Z_i,isionised=isionised(i)) else diff --git a/src/main/dens.F90 b/src/main/dens.F90 index 65ad2c82f..cf692d735 100644 --- a/src/main/dens.F90 +++ b/src/main/dens.F90 @@ -116,9 +116,9 @@ module densityforce !+ !---------------------------------------------------------------- subroutine densityiterate(icall,npart,nactive,xyzh,vxyzu,divcurlv,divcurlB,Bevol,stressmax,& - fxyzu,fext,alphaind,gradh,rad,radprop,dvdx) + fxyzu,fext,alphaind,gradh,rad,radprop,dvdx,apr_level) use dim, only:maxp,maxneigh,ndivcurlv,ndivcurlB,maxalpha,mhd_nonideal,nalpha,& - use_dust,fast_divcurlB,mpi,gr + use_dust,fast_divcurlB,mpi,gr,use_apr use io, only:iprint,fatal,iverbose,id,master,real4,warning,error,nprocs use linklist, only:ifirstincell,ncells,get_neighbour_list,get_hmaxcell,& listneigh,get_cell_location,set_hmaxcell,sync_hmax_mpi @@ -137,7 +137,8 @@ subroutine densityiterate(icall,npart,nactive,xyzh,vxyzu,divcurlv,divcurlB,Bevol use io_summary,only:summary_variable,iosumhup,iosumhdn use timing, only:increment_timer,get_timings,itimer_dens_local,itimer_dens_remote use omputils, only:omp_thread_num,omp_num_threads - integer, intent(in) :: icall,npart,nactive + integer, intent(in) :: icall,npart,nactive + integer(kind=1), intent(in) :: apr_level(:) real, intent(inout) :: xyzh(:,:) real, intent(in) :: vxyzu(:,:),fxyzu(:,:),fext(:,:) real, intent(in) :: Bevol(:,:) @@ -194,6 +195,7 @@ subroutine densityiterate(icall,npart,nactive,xyzh,vxyzu,divcurlv,divcurlB,Bevol nwarnroundoff = 0 np = 0 endif + ! ! flag for whether or not we need to calculate velocity derivatives ! whilst doing the density iterations (needed for viscosity switches @@ -236,6 +238,7 @@ subroutine densityiterate(icall,npart,nactive,xyzh,vxyzu,divcurlv,divcurlB,Bevol !$omp shared(fext) & !$omp shared(gradh) & !$omp shared(iphase) & +!$omp shared(apr_level) & !$omp shared(Bevol) & !$omp shared(divcurlv) & !$omp shared(divcurlB) & @@ -321,7 +324,7 @@ subroutine densityiterate(icall,npart,nactive,xyzh,vxyzu,divcurlv,divcurlB,Bevol cell%nits = 0 cell%nneigh = 0 - call start_cell(cell,iphase,xyzh,vxyzu,fxyzu,fext,Bevol,rad) + call start_cell(cell,iphase,xyzh,vxyzu,fxyzu,fext,Bevol,rad,apr_level) call get_cell_location(icell,cell%xpos,cell%xsizei,cell%rcuti) call get_hmaxcell(icell,cell%hmax) @@ -341,7 +344,7 @@ subroutine densityiterate(icall,npart,nactive,xyzh,vxyzu,divcurlv,divcurlB,Bevol endif endif - call compute_cell(cell,listneigh,nneigh,getdv,getdB,Bevol,xyzh,vxyzu,fxyzu,fext,xyzcache,rad) + call compute_cell(cell,listneigh,nneigh,getdv,getdB,Bevol,xyzh,vxyzu,fxyzu,fext,xyzcache,rad,apr_level) if (do_export) then call write_cell(stack_waiting,cell) @@ -374,7 +377,7 @@ subroutine densityiterate(icall,npart,nactive,xyzh,vxyzu,divcurlv,divcurlB,Bevol nrelink = nrelink + 1 endif - call compute_cell(cell,listneigh,nneigh,getdv,getdB,Bevol,xyzh,vxyzu,fxyzu,fext,xyzcache,rad) + call compute_cell(cell,listneigh,nneigh,getdv,getdB,Bevol,xyzh,vxyzu,fxyzu,fext,xyzcache,rad,apr_level) if (do_export) then call write_cell(stack_waiting,cell) @@ -444,7 +447,7 @@ subroutine densityiterate(icall,npart,nactive,xyzh,vxyzu,divcurlv,divcurlB,Bevol call get_neighbour_list(-1,listneigh,nneigh,xyzh,xyzcache,isizecellcache,getj=.false., & cell_xpos=cell%xpos,cell_xsizei=cell%xsizei,cell_rcuti=cell%rcuti) - call compute_cell(cell,listneigh,nneigh,getdv,getdB,Bevol,xyzh,vxyzu,fxyzu,fext,xyzcache,rad) + call compute_cell(cell,listneigh,nneigh,getdv,getdB,Bevol,xyzh,vxyzu,fxyzu,fext,xyzcache,rad,apr_level) remote_export = .false. remote_export(cell%owner+1) = .true. ! use remote_export array to send back to the owner @@ -505,7 +508,7 @@ subroutine densityiterate(icall,npart,nactive,xyzh,vxyzu,divcurlv,divcurlB,Bevol call reserve_stack(stack_redo,cell%waiting_index) call send_cell(cell,remote_export,irequestsend,xsendbuf,cell_counters,mpitype) ! send the cell to remote - call compute_cell(cell,listneigh,nneigh,getdv,getdB,Bevol,xyzh,vxyzu,fxyzu,fext,xyzcache,rad) + call compute_cell(cell,listneigh,nneigh,getdv,getdB,Bevol,xyzh,vxyzu,fxyzu,fext,xyzcache,rad,apr_level) call write_cell(stack_redo,cell) else @@ -589,23 +592,25 @@ end subroutine densityiterate ! MAKE SURE THIS ROUTINE IS INLINED BY THE COMPILER !+ !---------------------------------------------------------------- -pure subroutine get_density_sums(i,xpartveci,hi,hi1,hi21,iamtypei,iamgasi,iamdusti,& +pure subroutine get_density_sums(i,xpartveci,hi,hi1,hi21,iamtypei,iamgasi,iamdusti,apri,& listneigh,nneigh,nneighi,dxcache,xyzcache,rhosum,& ifilledcellcache,ifilledneighcache,getdv,getdB,& - realviscosity,xyzh,vxyzu,Bevol,fxyzu,fext,ignoreself,rad) + realviscosity,xyzh,vxyzu,Bevol,fxyzu,fext,ignoreself,rad,apr_level) #ifdef PERIODIC use boundary, only:dxbound,dybound,dzbound #endif use kernel, only:get_kernel,get_kernel_grav1 - use part, only:iphase,iamgas,iamdust,iamtype,maxphase,ibasetype,igas,idust,rhoh,massoftype,iradxi - use dim, only:ndivcurlv,gravity,maxp,nalpha,use_dust,do_radiation + use part, only:iphase,iamgas,iamdust,iamtype,maxphase,ibasetype,igas,idust,rhoh + use part, only:massoftype,iradxi,aprmassoftype + use dim, only:ndivcurlv,gravity,maxp,nalpha,use_dust,do_radiation,use_apr use options, only:implicit_radiation integer, intent(in) :: i real, intent(in) :: xpartveci(:) real(kind=8), intent(in) :: hi,hi1,hi21 - integer, intent(in) :: iamtypei + integer, intent(in) :: iamtypei,apri logical, intent(in) :: iamgasi,iamdusti integer, intent(in) :: listneigh(:) + integer(kind=1), intent(in) :: apr_level(:) integer, intent(in) :: nneigh integer, intent(out) :: nneighi real, intent(inout) :: dxcache(:,:) @@ -626,7 +631,7 @@ pure subroutine get_density_sums(i,xpartveci,hi,hi1,hi21,iamtypei,iamgasi,iamdus real :: wabi,grkerni,dwdhi,dphidhi real :: projv,dvx,dvy,dvz,dax,day,daz real :: projdB,dBx,dBy,dBz,fxi,fyi,fzi,fxj,fyj,fzj - real :: rhoi, rhoj + real :: rhoi, rhoj,pmassi,pmassj logical :: same_type,gas_gas,iamdustj real :: dradenij @@ -733,11 +738,21 @@ pure subroutine get_density_sums(i,xpartveci,hi,hi1,hi21,iamtypei,iamgasi,iamdus gas_gas = (iamgasi .and. same_type) ! this ensure that boundary particles are included in gas_gas calculations endif + ! adjust masses for apr + ! this defaults to massoftype if apr_level=1 + if (use_apr) then + pmassi = aprmassoftype(iamtypei,apri) + pmassj = aprmassoftype(iamtypej,apr_level(j)) + else + pmassi = massoftype(iamtypei) + pmassj = massoftype(iamtypej) + endif + sametype: if (same_type) then dwdhi = (-qi*grkerni - 3.*wabi) - rhosum(irhoi) = rhosum(irhoi) + wabi - rhosum(igradhi) = rhosum(igradhi) + dwdhi - rhosum(igradsofti) = rhosum(igradsofti) + dphidhi + rhosum(irhoi) = rhosum(irhoi) + wabi*pmassj + rhosum(igradhi) = rhosum(igradhi) + dwdhi*pmassj + rhosum(igradsofti) = rhosum(igradsofti) + dphidhi*pmassj nneighi = nneighi + 1 ! ! calculate things needed for viscosity switches @@ -752,9 +767,9 @@ pure subroutine get_density_sums(i,xpartveci,hi,hi1,hi21,iamtypei,iamgasi,iamdus dz = dxcache(7,n) endif rij1grkern = rij1*grkerni - runix = dx*rij1grkern - runiy = dy*rij1grkern - runiz = dz*rij1grkern + runix = dx*rij1grkern*pmassi + runiy = dy*rij1grkern*pmassi + runiz = dz*rij1grkern*pmassi if (getdv) then !--get dv and den @@ -808,8 +823,8 @@ pure subroutine get_density_sums(i,xpartveci,hi,hi1,hi21,iamtypei,iamgasi,iamdus ! we need B instead of B/rho, so used our estimated h here ! either it is close enough to be converged, ! or worst case it runs another iteration and re-calculates - rhoi = rhoh(real(hi), massoftype(igas)) - rhoj = rhoh(xyzh(4,j), massoftype(igas)) + rhoi = rhoh(real(hi), pmassi) + rhoj = rhoh(xyzh(4,j), pmassj) dBx = xpartveci(iBevolxi)*rhoi - Bevol(1,j)*rhoj dBy = xpartveci(iBevolyi)*rhoi - Bevol(2,j)*rhoj dBz = xpartveci(iBevolzi)*rhoi - Bevol(3,j)*rhoj @@ -830,8 +845,8 @@ pure subroutine get_density_sums(i,xpartveci,hi,hi1,hi21,iamtypei,iamgasi,iamdus endif if (do_radiation .and. gas_gas .and. .not. implicit_radiation) then - rhoi = rhoh(real(hi), massoftype(igas)) - rhoj = rhoh(xyzh(4,j), massoftype(igas)) + rhoi = rhoh(real(hi), pmassi) + rhoj = rhoh(xyzh(4,j), pmassj) dradenij = rad(iradxi,j)*rhoj - xpartveci(iradxii)*rhoi rhosum(iradfxi) = rhosum(iradfxi) + dradenij*runix rhosum(iradfyi) = rhosum(iradfyi) + dradenij*runiy @@ -1192,11 +1207,11 @@ end subroutine reduce_and_print_neighbour_stats !+ !-------------------------------------------------------------------------- pure subroutine compute_cell(cell,listneigh,nneigh,getdv,getdB,Bevol,xyzh,vxyzu,fxyzu,fext, & - xyzcache,rad) + xyzcache,rad,apr_level) use part, only:get_partinfo,iamgas,igas,maxphase use viscosity, only:irealvisc use io, only:id - use dim, only:mpi + use dim, only:mpi,use_apr type(celldens), intent(inout) :: cell @@ -1208,6 +1223,7 @@ pure subroutine compute_cell(cell,listneigh,nneigh,getdv,getdB,Bevol,xyzh,vxyzu, real, intent(in) :: xyzh(:,:),vxyzu(:,:),fxyzu(:,:),fext(:,:) real, intent(in) :: xyzcache(isizecellcache,3) real, intent(in) :: rad(:,:) + integer(kind=1), intent(in) :: apr_level(:) real :: dxcache(7,isizeneighcache) @@ -1219,7 +1235,7 @@ pure subroutine compute_cell(cell,listneigh,nneigh,getdv,getdB,Bevol,xyzh,vxyzu, logical :: realviscosity logical :: ignoreself - integer :: nneighi + integer :: nneighi,apri integer :: i,lli realviscosity = (irealvisc > 0) @@ -1241,12 +1257,19 @@ pure subroutine compute_cell(cell,listneigh,nneigh,getdv,getdB,Bevol,xyzh,vxyzu, hi31 = hi1*hi21 hi41 = hi21*hi21 + if (use_apr) then + apri = cell%apr(i) + else + apri = 1 + endif + + ignoreself = (cell%owner == id) call get_density_sums(lli,cell%xpartvec(:,i),hi,hi1,hi21,iamtypei,iamgasi,iamdusti,& - listneigh,nneigh,nneighi,dxcache,xyzcache,cell%rhosums(:,i),& - .true.,.false.,getdv,getdB,realviscosity,& - xyzh,vxyzu,Bevol,fxyzu,fext,ignoreself,rad) + apri,listneigh,nneigh,nneighi,dxcache,xyzcache,& + cell%rhosums(:,i),.true.,.false.,getdv,getdB,realviscosity,& + xyzh,vxyzu,Bevol,fxyzu,fext,ignoreself,rad,apr_level) cell%nneightry = nneigh cell%nneigh(i) = nneighi @@ -1275,9 +1298,9 @@ end subroutine compute_hmax !-------------------------------------------------------------------------- !+ !-------------------------------------------------------------------------- -subroutine start_cell(cell,iphase,xyzh,vxyzu,fxyzu,fext,Bevol,rad) +subroutine start_cell(cell,iphase,xyzh,vxyzu,fxyzu,fext,Bevol,rad,apr_level) use io, only:fatal - use dim, only:maxp,maxvxyzu,do_radiation + use dim, only:maxp,maxvxyzu,do_radiation,use_apr use part, only:maxphase,get_partinfo,mhd,igas,iamgas,& iamboundary,ibasetype,iradxi @@ -1289,6 +1312,7 @@ subroutine start_cell(cell,iphase,xyzh,vxyzu,fxyzu,fext,Bevol,rad) real, intent(in) :: fext(:,:) real, intent(in) :: Bevol(:,:) real, intent(in) :: rad(:,:) + integer(kind=1), intent(in) :: apr_level(:) integer :: i,ip integer :: iamtypei @@ -1351,6 +1375,12 @@ subroutine start_cell(cell,iphase,xyzh,vxyzu,fxyzu,fext,Bevol,rad) if (do_radiation) cell%xpartvec(iradxii,cell%npcell) = rad(iradxi,i) + if (use_apr) then + cell%apr(cell%npcell) = apr_level(i) + else + cell%apr(cell%npcell) = 1 + endif + enddo over_parts end subroutine start_cell @@ -1358,8 +1388,9 @@ end subroutine start_cell !+ !-------------------------------------------------------------------------- subroutine finish_cell(cell,cell_converged) + use dim, only:use_apr use io, only:iprint,fatal - use part, only:get_partinfo,iamgas,maxphase,massoftype,igas,hrho + use part, only:get_partinfo,iamgas,maxphase,massoftype,igas,hrho,aprmassoftype use options, only:tolh type(celldens), intent(inout) :: cell @@ -1370,7 +1401,7 @@ subroutine finish_cell(cell,cell_converged) real(kind=8) :: gradhi real :: func,dfdh1,hi,hi_old,hnew real :: pmassi, xyzh(4) - integer :: i,iamtypei !,nwarnup,nwarndown + integer :: i,iamtypei,apri !,nwarnup,nwarndown logical :: iactivei,iamgasi,iamdusti,converged cell%nits = cell%nits + 1 @@ -1389,7 +1420,12 @@ subroutine finish_cell(cell,cell_converged) endif !if (.not.iactivei) print*,' ERROR: should be no inactive particles here',iamtypei,iactivei - pmassi = massoftype(iamtypei) + apri = cell%apr(i) + if (use_apr) then + pmassi = aprmassoftype(iamtypei,apri) + else + pmassi = massoftype(iamtypei) + endif call finish_rhosum(rhosum,pmassi,hi,.true.,rhoi=rhoi,rhohi=rhohi,& gradhi=gradhi,dhdrhoi_out=dhdrhoi,omegai_out=omegai) @@ -1459,8 +1495,8 @@ pure subroutine finish_rhosum(rhosum,pmassi,hi,iterating,rhoi,rhohi,gradhi,grads hi31 = hi1*hi21 hi41 = hi21*hi21 - rhoi = cnormk*pmassi*(rhosum(irhoi) + wab0)*hi31 - gradhi = cnormk*pmassi*(rhosum(igradhi) + gradh0)*hi41 + rhoi = cnormk*(rhosum(irhoi) + wab0*pmassi)*hi31 + gradhi = cnormk*(rhosum(igradhi) + gradh0*pmassi)*hi41 dhdrhoi = dhdrho(hi,pmassi) omegai = 1. - dhdrhoi*gradhi @@ -1471,7 +1507,7 @@ pure subroutine finish_rhosum(rhosum,pmassi,hi,iterating,rhoi,rhohi,gradhi,grads dhdrhoi_out = dhdrhoi omegai_out = omegai else - gradsofti = pmassi*(rhosum(igradsofti) + dphidh0)*hi21 ! NB: no cnormk in gradsoft + gradsofti = (rhosum(igradsofti) + dphidh0*pmassi)*hi21 ! NB: no cnormk in gradsoft gradsofti = gradsofti*dhdrhoi endif @@ -1485,9 +1521,9 @@ subroutine store_results(icall,cell,getdv,getdb,realviscosity,stressmax,xyzh,& maxneighact,np,ncalc,radprop) use part, only:hrho,rhoh,get_partinfo,iamgas,& mhd,maxphase,massoftype,igas,ndustlarge,ndustsmall,xyzh_soa,& - maxgradh,idust,ifluxx,ifluxz,ithick + maxgradh,idust,ifluxx,ifluxz,ithick,aprmassoftype use io, only:fatal,real4 - use dim, only:maxp,ndivcurlv,ndivcurlB,nalpha,use_dust,do_radiation + use dim, only:maxp,ndivcurlv,ndivcurlB,nalpha,use_dust,do_radiation,use_apr use options, only:use_dustfrac,implicit_radiation use viscosity, only:bulkvisc,shearparam use linklist, only:set_hmaxcell @@ -1519,7 +1555,7 @@ subroutine store_results(icall,cell,getdv,getdb,realviscosity,stressmax,xyzh,& real :: rhosum(maxrhosum) - integer :: iamtypei,i,lli,l + integer :: iamtypei,i,lli,l,apri logical :: iactivei,iamgasi,iamdusti logical :: igotrmatrix real :: hi,hi1,hi21,hi31,hi41 @@ -1550,7 +1586,12 @@ subroutine store_results(icall,cell,getdv,getdb,realviscosity,stressmax,xyzh,& iamdusti = .false. endif - pmassi = massoftype(iamtypei) + apri = cell%apr(i) + if (use_apr) then + pmassi = aprmassoftype(iamtypei,apri) + else + pmassi = massoftype(iamtypei) + endif if (calculate_density) then call finish_rhosum(rhosum,pmassi,hi,.false.,rhoi=rhoi,gradhi=gradhi,gradsofti=gradsofti) @@ -1586,7 +1627,7 @@ subroutine store_results(icall,cell,getdv,getdb,realviscosity,stressmax,xyzh,& dustfrac(:,lli) = 0. if (iamgasi) then do l=1,ndustlarge - rhodusti(l) = cnormk*massoftype(idust+l-1)*(rhosum(irhodusti+l-1))*hi31 + rhodusti(l) = cnormk*massoftype(idust+l-1)*(rhosum(irhodusti+l-1))*hi31 !TDB fix apr here dustfrac(ndustsmall+l,lli) = rhodusti(l)*rho1i ! dust-to-gas ratio enddo endif @@ -1596,7 +1637,7 @@ subroutine store_results(icall,cell,getdv,getdb,realviscosity,stressmax,xyzh,& ! igotrmatrix = .false. - term = cnormk*pmassi*gradhi*rho1i*hi41 + term = cnormk*gradhi*rho1i*hi41 if (getdv) then call calculate_rmatrix_from_sums(rhosum,denom,rmatrix,igotrmatrix) call calculate_divcurlv_from_sums(rhosum,term,divcurlvi,ndivcurlv,denom,rmatrix) diff --git a/src/main/deriv.F90 b/src/main/deriv.F90 index d11d5ae4b..cd7149405 100644 --- a/src/main/deriv.F90 +++ b/src/main/deriv.F90 @@ -36,7 +36,8 @@ module deriv !------------------------------------------------------------- subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& Bevol,dBevol,rad,drad,radprop,dustprop,ddustprop,& - dustevol,ddustevol,filfac,dustfrac,eos_vars,time,dt,dtnew,pxyzu,dens,metrics) + dustevol,ddustevol,filfac,dustfrac,eos_vars,time,dt,dtnew,pxyzu,& + dens,metrics,apr_level) use dim, only:maxvxyzu,mhd,fast_divcurlB,gr,periodic,do_radiation,& sink_radiation,use_dustgrowth,ind_timesteps use io, only:iprint,fatal,error @@ -86,6 +87,7 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& real, intent(out) :: dtnew real, intent(inout) :: pxyzu(:,:), dens(:) real, intent(inout) :: metrics(:,:,:,:) + integer(kind=1), intent(in) :: apr_level(:) integer :: ierr,i real(kind=4) :: t1,tcpu1,tlast,tcpulast @@ -130,15 +132,16 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& ! ! calculate density by direct summation ! + if (icall==1) then call densityiterate(1,npart,nactive,xyzh,vxyzu,divcurlv,divcurlB,Bevol,& - stressmax,fxyzu,fext,alphaind,gradh,rad,radprop,dvdx) + stressmax,fxyzu,fext,alphaind,gradh,rad,radprop,dvdx,apr_level) if (.not. fast_divcurlB) then ! Repeat the call to calculate all the non-density-related quantities in densityiterate. ! This needs to be separate for an accurate calculation of divcurlB which requires an up-to-date rho. ! if fast_divcurlB = .false., then all additional quantities are calculated during the previous call call densityiterate(3,npart,nactive,xyzh,vxyzu,divcurlv,divcurlB,Bevol,& - stressmax,fxyzu,fext,alphaind,gradh,rad,radprop,dvdx) + stressmax,fxyzu,fext,alphaind,gradh,rad,radprop,dvdx,apr_level) endif set_boundaries_to_active = .false. ! boundary particles are no longer treated as active call do_timing('dens',tlast,tcpulast) @@ -172,7 +175,7 @@ subroutine derivs(icall,npart,nactive,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& if (sinks_have_heating(nptmass,xyzmh_ptmass)) call ptmass_calc_enclosed_mass(nptmass,npart,xyzh) call force(icall,npart,xyzh,vxyzu,fxyzu,divcurlv,divcurlB,Bevol,dBevol,& rad,drad,radprop,dustprop,dustgasprop,dustfrac,ddustevol,fext,fxyz_drag,& - ipart_rhomax,dt,stressmax,eos_vars,dens,metrics) + ipart_rhomax,dt,stressmax,eos_vars,dens,metrics,apr_level) call do_timing('force',tlast,tcpulast) if (use_dustgrowth) then ! compute growth rate of dust particles @@ -223,7 +226,8 @@ end subroutine derivs subroutine get_derivs_global(tused,dt_new,dt) use part, only:npart,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& Bevol,dBevol,rad,drad,radprop,dustprop,ddustprop,filfac,& - dustfrac,ddustevol,eos_vars,pxyzu,dens,metrics,dustevol,gr + dustfrac,ddustevol,eos_vars,pxyzu,dens,metrics,dustevol,gr,& + apr_level use timing, only:printused,getused use io, only:id,master use cons2prim, only:prim2consall @@ -248,7 +252,7 @@ subroutine get_derivs_global(tused,dt_new,dt) ! evaluate derivatives call derivs(1,npart,npart,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,Bevol,dBevol,& rad,drad,radprop,dustprop,ddustprop,dustevol,ddustevol,filfac,dustfrac,& - eos_vars,time,dti,dtnew,pxyzu,dens,metrics) + eos_vars,time,dti,dtnew,pxyzu,dens,metrics,apr_level) call getused(t2) if (id==master .and. present(tused)) call printused(t1) if (present(tused)) tused = t2 - t1 diff --git a/src/main/energies.F90 b/src/main/energies.F90 index 7687b696e..acea5414a 100644 --- a/src/main/energies.F90 +++ b/src/main/energies.F90 @@ -64,7 +64,8 @@ module energies !---------------------------------------------------------------- subroutine compute_energies(t) use dim, only:maxp,maxvxyzu,maxalpha,maxtypes,mhd_nonideal,maxp_hard,& - lightcurve,use_dust,maxdusttypes,do_radiation,gr,use_krome + lightcurve,use_dust,maxdusttypes,do_radiation,gr,use_krome,& + use_apr use part, only:rhoh,xyzh,vxyzu,massoftype,npart,maxphase,iphase,& alphaind,Bevol,divcurlB,iamtype,igamma,& igas,idust,iboundary,istar,idarkmatter,ibulge,& @@ -73,7 +74,7 @@ subroutine compute_energies(t) ispinz,mhd,gravity,poten,dustfrac,eos_vars,itemp,igasP,ics,& nden_nimhd,eta_nimhd,iion,ndustsmall,graindens,grainsize,& iamdust,ndusttypes,rad,iradxi,gtgrad,group_info,bin_info,n_group - use part, only:pxyzu,fxyzu,fext + use part, only:pxyzu,fxyzu,fext,apr_level,aprmassoftype use gravwaveutils, only:calculate_strain,calc_gravitwaves use centreofmass, only:get_centreofmass_accel use eos, only:polyk,gamma,eos_is_non_ideal,eos_outputs_gasP @@ -172,7 +173,7 @@ subroutine compute_energies(t) !$omp parallel default(none) & !$omp shared(maxp,maxphase,maxalpha) & !$omp shared(xyzh,vxyzu,pxyzu,rad,iexternalforce,npart,t,id) & -!$omp shared(alphaind,massoftype,irealvisc,iu) & +!$omp shared(alphaind,massoftype,irealvisc,iu,aprmassoftype) & !$omp shared(ieos,gamma,nptmass,xyzmh_ptmass,vxyz_ptmass,xyzcom) & !$omp shared(Bevol,divcurlB,iphase,poten,dustfrac,use_dustfrac) & !$omp shared(use_ohm,use_hall,use_ambi,nden_nimhd,eta_nimhd,eta_constant) & @@ -195,7 +196,7 @@ subroutine compute_energies(t) !$omp private(pxi,pyi,pzi,gammaijdown,alpha_gr,beta_gr_UP,bigvi,lorentzi,pdotv,angi,fourvel_space) & !$omp shared(idrag) & !$omp private(tsi,iregime,idusttype,was_not_accreted) & -!$omp shared(luminosity,track_lum) & +!$omp shared(luminosity,track_lum,apr_level) & !$omp reduction(+:np,npgas,np_cs_eq_0,np_e_eq_0) & !$omp reduction(+:xcom,ycom,zcom,mtot,xmom,ymom,zmom,angx,angy,angz,mdust,mgas) & !$omp reduction(+:xmomacc,ymomacc,zmomacc,angaccx,angaccy,angaccz) & @@ -214,7 +215,17 @@ subroutine compute_energies(t) if (maxphase==maxp) then itype = iamtype(iphase(i)) if (itype <= 0) call fatal('energies','particle type <= 0') - pmassi = massoftype(itype) + if (use_apr) then + pmassi = aprmassoftype(itype,apr_level(i)) + else + pmassi = massoftype(itype) + endif + else + if (use_apr) then + pmassi = aprmassoftype(igas,apr_level(i)) + else + pmassi = massoftype(igas) + endif endif rhoi = rhoh(hi,pmassi) @@ -763,7 +774,11 @@ subroutine compute_energies(t) if (track_lum) totlum = ev_data(iev_sum,iev_totlum) if (calc_gravitwaves) then - pmassi = massoftype(igas) + if (use_apr) then + pmassi = aprmassoftype(igas,apr_level(i)) + else + pmassi = massoftype(igas) + endif x0 = 0.; v0 = 0.; a0 = 0. ! use the origin by default if (gr) then !call get_geodesic_accel(axyz,npart,vxyzu(1:3,:),metrics,metricderivs) @@ -820,7 +835,7 @@ subroutine get_erot(xi,yi,zi,vxi,vyi,vzi,xyzcom,pmassi,erotxi,erotyi,erotzi) real, intent(out) :: erotxi,erotyi,erotzi real :: dx,dy,dz,dvx,dvy,dvz real :: rcrossvx,rcrossvy,rcrossvz,radxy2,radyz2,radxz2 - ! + erotxi = 0.0 erotyi = 0.0 erotzi = 0.0 @@ -847,7 +862,7 @@ subroutine get_erot(xi,yi,zi,vxi,vyi,vzi,xyzcom,pmassi,erotxi,erotyi,erotzi) end subroutine get_erot !---------------------------------------------------------------- !+ -! initiallised the ev_data array +! initialise the ev_data array !+ !---------------------------------------------------------------- subroutine initialise_ev_data(evdata) @@ -909,5 +924,5 @@ subroutine finalise_ev_data(evdata,dnptot) enddo end subroutine finalise_ev_data -!---------------------------------------------------------------- + end module energies diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index fb7c5cc8d..2c9be7286 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -37,11 +37,12 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) dtmax_ifactor,dtmax_ifactorWT,dtmax_dratio,check_dtmax_for_decrease,& idtmax_n,idtmax_frac,idtmax_n_next,idtmax_frac_next use evwrite, only:write_evfile,write_evlog - use energies, only:etot,totmom,angtot,mdust,np_cs_eq_0,np_e_eq_0,hdivBonB_ave,hdivBonB_max + use energies, only:etot,totmom,angtot,mdust,np_cs_eq_0,np_e_eq_0,hdivBonB_ave,& + hdivBonB_max,mtot use checkconserved, only:etot_in,angtot_in,totmom_in,mdust_in,& init_conservation_checks,check_conservation_error,& - check_magnetic_stability - use dim, only:maxvxyzu,mhd,periodic,idumpfile,ind_timesteps + check_magnetic_stability,mtot_in + use dim, only:maxvxyzu,mhd,periodic,idumpfile,use_apr,ind_timesteps use fileutils, only:getnextfilename use options, only:nfulldump,twallmax,nmaxdumps,rhofinal1,iexternalforce,rkill use readwrite_infile, only:write_infile @@ -78,7 +79,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) #endif use dim, only:do_radiation use options, only:exchange_radiation_energy,implicit_radiation - use part, only:rad,radprop + use part, only:rad,radprop,igas use radiation_utils, only:update_radenergy use timestep, only:dtrad #ifdef LIVE_ANALYSIS @@ -87,9 +88,11 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) use fileutils, only:numfromfile use io, only:ianalysis #endif + use apr, only:update_apr,create_or_update_apr_clump use part, only:npart,nptmass,xyzh,vxyzu,fxyzu,fext,divcurlv,massoftype, & xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dptmass,gravity,iboundary, & - fxyz_ptmass_sinksink,ntot,poten,ndustsmall,accrete_particles_outside_sphere,& + fxyz_ptmass_sinksink,ntot,poten,ndustsmall,& + accrete_particles_outside_sphere,apr_level,aprmassoftype,& linklist_ptmass,isionised,dsdt_ptmass,isdead_or_accreted use part, only:n_group,n_ingroup,n_sing,group_info,bin_info,nmatrix use quitdump, only:quit @@ -139,7 +142,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) #endif logical :: fulldump,abortrun,abortrun_bdy,at_dump_time,writedump logical :: should_conserve_energy,should_conserve_momentum,should_conserve_angmom - logical :: should_conserve_dustmass + logical :: should_conserve_dustmass,should_conserve_aprmass logical :: use_global_dt integer :: j,nskip,nskipped,nevwrite_threshold,nskipped_sink,nsinkwrite_threshold character(len=120) :: dumpfile_orig @@ -159,7 +162,8 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) abortrun_bdy = .false. call init_conservation_checks(should_conserve_energy,should_conserve_momentum,& - should_conserve_angmom,should_conserve_dustmass) + should_conserve_angmom,should_conserve_dustmass,& + should_conserve_aprmass) noutput = 1 noutput_dtmax = 1 @@ -240,6 +244,11 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) endif #endif + if (use_apr) then + ! split or merge as required + call update_apr(npart,xyzh,vxyzu,fxyzu,apr_level) + endif + dtmaxold = dtmax #ifdef IND_TIMESTEPS istepfrac = istepfrac + 1 @@ -284,8 +293,12 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) ! ! creation of new sink particles ! - call ptmass_create(nptmass,npart,ipart_rhomax,xyzh,vxyzu,fxyzu,fext,divcurlv,& + if (use_apr) then + call create_or_update_apr_clump(npart,xyzh,vxyzu,poten,apr_level,xyzmh_ptmass,aprmassoftype) + else + call ptmass_create(nptmass,npart,ipart_rhomax,xyzh,vxyzu,fxyzu,fext,divcurlv,& poten,massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,linklist_ptmass,dptmass,time) + endif endif if (icreate_sinks == 2) then @@ -450,6 +463,7 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) enddo endif if (mhd) call check_magnetic_stability(hdivBonB_ave,hdivBonB_max) + if (should_conserve_aprmass) call check_conservation_error(mtot,mtot_in,massoftype(igas),'total mass') if (id==master) then if (np_e_eq_0 > 0) call warning('evolve','N gas particles with energy = 0',var='N',ival=int(np_e_eq_0,kind=4)) if (np_cs_eq_0 > 0) call warning('evolve','N gas particles with sound speed = 0',var='N',ival=int(np_cs_eq_0,kind=4)) diff --git a/src/main/force.F90 b/src/main/force.F90 index 494f00186..3051acec9 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -182,15 +182,15 @@ module forces !---------------------------------------------------------------- subroutine force(icall,npart,xyzh,vxyzu,fxyzu,divcurlv,divcurlB,Bevol,dBevol,& rad,drad,radprop,dustprop,dustgasprop,dustfrac,ddustevol,fext,fxyz_drag,& - ipart_rhomax,dt,stressmax,eos_vars,dens,metrics) + ipart_rhomax,dt,stressmax,eos_vars,dens,metrics,apr_level) - use dim, only:maxvxyzu,maxneigh,mhd,mhd_nonideal,lightcurve,mpi,use_dust + use dim, only:maxvxyzu,maxneigh,mhd,mhd_nonideal,lightcurve,mpi,use_dust,use_apr use io, only:iprint,fatal,iverbose,id,master,real4,warning,error,nprocs use linklist, only:ncells,get_neighbour_list,get_hmaxcell,get_cell_location,listneigh use options, only:iresistive_heating use part, only:rhoh,dhdrho,rhoanddhdrho,alphaind,iactive,gradh,& hrho,iphase,igas,maxgradh,dvdx,eta_nimhd,deltav,poten,iamtype,& - dragreg,filfac,fxyz_dragold + dragreg,filfac,fxyz_dragold,aprmassoftype use timestep, only:dtcourant,dtforce,dtrad,bignumber,dtdiff use io_summary, only:summary_variable, & iosumdtf,iosumdtd,iosumdtv,iosumdtc,iosumdto,iosumdth,iosumdta, & @@ -232,6 +232,7 @@ subroutine force(icall,npart,xyzh,vxyzu,fxyzu,divcurlv,divcurlB,Bevol,dBevol,& use omputils, only:omp_thread_num,omp_num_threads integer, intent(in) :: icall,npart + integer(kind=1), intent(in) :: apr_level(:) real, intent(in) :: xyzh(:,:) real, intent(inout) :: vxyzu(:,:) real, intent(in) :: dustfrac(:,:) @@ -429,6 +430,7 @@ subroutine force(icall,npart,xyzh,vxyzu,fxyzu,divcurlv,divcurlB,Bevol,dBevol,& !$omp private(mpitype) & !$omp shared(dens) & !$omp shared(metrics) & +!$omp shared(apr_level,aprmassoftype) & #ifdef GRAVITY !$omp shared(massoftype,npart,maxphase) & !$omp private(hi,pmassi,rhoi) & @@ -495,7 +497,7 @@ subroutine force(icall,npart,xyzh,vxyzu,fxyzu,divcurlv,divcurlB,Bevol,dBevol,& call start_cell(cell,iphase,xyzh,vxyzu,gradh,divcurlv,divcurlB,dvdx,Bevol, & dustfrac,dustprop,fxyz_dragold,eta_nimhd,eos_vars,alphaind,stressmax,& - rad,radprop,dens,metrics,dt) + rad,radprop,dens,metrics,apr_level,dt) if (cell%npcell == 0) cycle over_cells call get_cell_location(icell,cell%xpos,cell%xsizei,cell%rcuti) @@ -526,7 +528,7 @@ subroutine force(icall,npart,xyzh,vxyzu,fxyzu,divcurlv,divcurlB,Bevol,dBevol,& call compute_cell(cell,listneigh,nneigh,Bevol,xyzh,vxyzu,fxyzu, & iphase,divcurlv,divcurlB,alphaind,eta_nimhd,eos_vars, & dustfrac,dustprop,fxyz_dragold,gradh,ibinnow_m1,ibin_wake,stressmax,xyzcache,& - rad,radprop,dens,metrics,dt) + rad,radprop,dens,metrics,apr_level,dt) if (do_export) then call write_cell(stack_waiting,cell) @@ -586,7 +588,7 @@ subroutine force(icall,npart,xyzh,vxyzu,fxyzu,divcurlv,divcurlB,Bevol,dBevol,& call compute_cell(cell,listneigh,nneigh,Bevol,xyzh,vxyzu,fxyzu, & iphase,divcurlv,divcurlB,alphaind,eta_nimhd,eos_vars, & dustfrac,dustprop,fxyz_dragold,gradh,ibinnow_m1,ibin_wake,stressmax,xyzcache,& - rad,radprop,dens,metrics,dt) + rad,radprop,dens,metrics,apr_level,dt) remote_export = .false. remote_export(cell%owner+1) = .true. ! use remote_export array to send back to the owner @@ -672,7 +674,11 @@ subroutine force(icall,npart,xyzh,vxyzu,fxyzu,divcurlv,divcurlB,Bevol,dBevol,& else iamtypei = igas endif - pmassi = massoftype(iamtypei) + if (use_apr) then + pmassi = aprmassoftype(iamtypei,apr_level(i)) + else + pmassi = massoftype(iamtypei) + endif rhoi = rhoh(hi,pmassi) if (rhoi > rho_crit) then if (rhoi > rhomax_thread) then @@ -892,15 +898,15 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g dustfrac,dustprop,fxyz_drag,gradh,divcurlv,alphaind, & alphau,alphaB,bulkvisc,stressmax,& ndrag,nstokes,nsuper,ts_min,ibinnow_m1,ibin_wake,ibin_neighi,& - ignoreself,rad,radprop,dens,metrics,dt) + ignoreself,rad,radprop,dens,metrics,apr_level,dt) #ifdef FINVSQRT use fastmath, only:finvsqrt #endif use kernel, only:grkern,cnormk,radkern2 use part, only:igas,idust,iohm,ihall,iambi,maxphase,iactive,& iamtype,iamdust,get_partinfo,mhd,maxvxyzu,maxdvdx,igasP,ics,iradP,itemp - use dim, only:maxalpha,maxp,mhd_nonideal,gravity,gr - use part, only:rhoh,dvdx + use dim, only:maxalpha,maxp,mhd_nonideal,gravity,gr,use_apr + use part, only:rhoh,dvdx,aprmassoftype use nicil, only:nimhd_get_jcbcb,nimhd_get_dBdt use eos, only:ieos,eos_is_non_ideal #ifdef GRAVITY @@ -962,6 +968,7 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g logical, intent(in) :: ignoreself real, intent(in) :: rad(:,:),dens(:),metrics(:,:,:,:) real, intent(inout) :: radprop(:,:) + integer(kind=1), intent(in) :: apr_level(:) real, intent(in) :: dt integer :: j,n,iamtypej logical :: iactivej,iamgasj,iamdustj @@ -1312,9 +1319,13 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g endif #endif endif - pmassj = massoftype(iamtypej) + if (use_apr) then + pmassj = aprmassoftype(iamtypej,apr_level(j)) + else + pmassj = massoftype(iamtypej) + endif - fgrav = 0.5*pmassj*(fgravi + fgravj) + fgrav = 0.5*(pmassj*fgravi + pmassi*fgravj) ! If particle is hidden by the sink, treat the neighbour as ! not gas; gravitational contribution will be added after the @@ -1940,7 +1951,11 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g if (maxphase==maxp) then iamtypej = iamtype(iphase(j)) endif - pmassj = massoftype(iamtypej) + if (use_apr) then + pmassj = aprmassoftype(iamtypej,apr_level(j)) + else + pmassj = massoftype(iamtypej) + endif phii = -rij1 fgravj = fgrav*pmassj fsum(ifxi) = fsum(ifxi) - dx*fgravj @@ -2077,14 +2092,14 @@ end subroutine get_stress subroutine start_cell(cell,iphase,xyzh,vxyzu,gradh,divcurlv,divcurlB,dvdx,Bevol, & dustfrac,dustprop,fxyz_drag,eta_nimhd,eos_vars,alphaind,stressmax,& - rad,radprop,dens,metrics,dt) + rad,radprop,dens,metrics,apr_level,dt) use io, only:fatal use options, only:alpha,use_dustfrac,limit_radiation_flux use dim, only:maxp,ndivcurlv,ndivcurlB,maxdvdx,maxalpha,maxvxyzu,mhd,mhd_nonideal,& - use_dustgrowth,gr,use_dust,ind_timesteps + use_dustgrowth,gr,use_dust,ind_timesteps,use_apr use part, only:iamgas,maxphase,rhoanddhdrho,igas,massoftype,get_partinfo,& - iohm,ihall,iambi,ndustsmall,iradP,igasP,ics,itemp + iohm,ihall,iambi,ndustsmall,iradP,igasP,ics,itemp,aprmassoftype use viscosity, only:irealvisc,bulkvisc use dust, only:get_ts,idrag use options, only:use_porosity @@ -2115,6 +2130,7 @@ subroutine start_cell(cell,iphase,xyzh,vxyzu,gradh,divcurlv,divcurlB,dvdx,Bevol, real, intent(in) :: metrics(:,:,:,:) real, intent(in) :: eos_vars(:,:) real, intent(in) :: dt + integer(kind=1), intent(in) :: apr_level(:) real :: radRi real :: radPi @@ -2156,7 +2172,12 @@ subroutine start_cell(cell,iphase,xyzh,vxyzu,gradh,divcurlv,divcurlB,dvdx,Bevol, cycle over_parts endif - pmassi = massoftype(iamtypei) + if (use_apr) then + pmassi = aprmassoftype(iamtypei,apr_level(i)) + else + pmassi = massoftype(iamtypei) + endif + hi = xyzh(4,i) if (hi < 0.) call fatal('force','negative smoothing length',i,var='h',val=hi) @@ -2301,6 +2322,11 @@ subroutine start_cell(cell,iphase,xyzh,vxyzu,gradh,divcurlv,divcurlB,dvdx,Bevol, cell%xpartvec(iBevolxi:ipsi,cell%npcell) = 0. ! to avoid compiler warning endif endif + if (use_apr) then + cell%apr(cell%npcell) = apr_level(i) + else + cell%apr(cell%npcell) = 1 + endif alphai = alpha if (maxalpha==maxp) then @@ -2390,11 +2416,11 @@ end subroutine start_cell subroutine compute_cell(cell,listneigh,nneigh,Bevol,xyzh,vxyzu,fxyzu, & iphase,divcurlv,divcurlB,alphaind,eta_nimhd, eos_vars, & dustfrac,dustprop,fxyz_drag,gradh,ibinnow_m1,ibin_wake,stressmax,xyzcache,& - rad,radprop,dens,metrics,dt) + rad,radprop,dens,metrics,apr_level,dt) use io, only:error,id - use dim, only:maxvxyzu + use dim, only:maxvxyzu,use_apr use options, only:beta,alphau,alphaB,iresistive_heating - use part, only:get_partinfo,iamgas,mhd,igas,maxphase,massoftype + use part, only:get_partinfo,iamgas,mhd,igas,maxphase,massoftype,aprmassoftype use viscosity, only:irealvisc,bulkvisc type(cellforce), intent(inout) :: cell @@ -2423,6 +2449,7 @@ subroutine compute_cell(cell,listneigh,nneigh,Bevol,xyzh,vxyzu,fxyzu, & real, intent(inout) :: radprop(:,:) real, intent(in) :: dens(:),metrics(:,:,:,:) real, intent(in) :: dt + integer(kind=1), intent(in) :: apr_level(:) real :: hi real(kind=8) :: hi1,hi21,hi31,hi41 @@ -2461,7 +2488,11 @@ subroutine compute_cell(cell,listneigh,nneigh,Bevol,xyzh,vxyzu,fxyzu, & i = inodeparts(cell%arr_index(ip)) - pmassi = massoftype(iamtypei) + if (use_apr) then + pmassi = aprmassoftype(iamtypei,cell%apr(ip)) + else + pmassi = massoftype(iamtypei) + endif hi = cell%xpartvec(ihi,ip) hi1 = 1./hi @@ -2483,7 +2514,6 @@ subroutine compute_cell(cell,listneigh,nneigh,Bevol,xyzh,vxyzu,fxyzu, & !--loop over current particle's neighbours (includes self) ! ignoreself = (cell%owner == id) - call compute_forces(i,iamgasi,iamdusti,cell%xpartvec(:,ip),hi,hi1,hi21,hi41,gradhi,gradsofti, & beta, & pmassi,listneigh,nneigh,xyzcache,cell%fsums(:,ip),cell%vsigmax(ip), & @@ -2493,7 +2523,7 @@ subroutine compute_cell(cell,listneigh,nneigh,Bevol,xyzh,vxyzu,fxyzu, & dustfrac,dustprop,fxyz_drag,gradh,divcurlv,alphaind, & alphau,alphaB,bulkvisc,stressmax, & cell%ndrag,cell%nstokes,cell%nsuper,cell%tsmin(ip),ibinnow_m1,ibin_wake,cell%ibinneigh(ip), & - ignoreself,rad,radprop,dens,metrics,dt) + ignoreself,rad,radprop,dens,metrics,apr_level,dt) enddo over_parts @@ -2519,14 +2549,14 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv use io, only:fatal,warning use dim, only:mhd,mhd_nonideal,lightcurve,use_dust,maxdvdx,use_dustgrowth,gr,use_krome,& - store_dust_temperature,do_nucleation,update_muGamma,h2chemistry + store_dust_temperature,do_nucleation,update_muGamma,h2chemistry,use_apr use eos, only:ieos,iopacity_type use options, only:alpha,ipdv_heating,ishock_heating,psidecayfac,overcleanfac, & use_dustfrac,damp,icooling,implicit_radiation use part, only:rhoanddhdrho,iboundary,igas,maxphase,maxvxyzu,nptmass,xyzmh_ptmass,eos_vars, & massoftype,get_partinfo,tstop,strain_from_dvdx,ithick,iradP,sinks_have_heating,& luminosity,nucleation,idK2,idkappa,dust_temp,pxyzu,ndustsmall,imu,& - igamma + igamma,aprmassoftype use cooling, only:energ_cooling,cooling_in_step use ptmass_heating, only:energ_sinkheat use dust, only:drag_implicit @@ -2642,7 +2672,11 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv cycle over_parts endif - pmassi = massoftype(iamtypei) + if (use_apr) then + pmassi = aprmassoftype(iamtypei,cell%apr(ip)) + else + pmassi = massoftype(iamtypei) + endif i = inodeparts(cell%arr_index(ip)) diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 9ea8fc1a5..9843665fe 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -59,6 +59,7 @@ subroutine initialise() use metric, only:metric_type use metric_et_utils, only:read_tabulated_metric,gridinit integer :: ierr + ! !--write 'PHANTOM' and code version ! @@ -94,9 +95,11 @@ subroutine initialise() ! !--initialise openMP things if required ! - if (id==master) call print_cpuinfo() +! if (id==master) call print_cpuinfo() ! I have no idea why this doesn't work on my laptop + print*,'cpu info' if (id==master) call info_omp call init_omp + print*,'init_omp' ! !--initialise MPI domains ! @@ -122,7 +125,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use mpiutils, only:reduceall_mpi,barrier_mpi,reduce_in_place_mpi use dim, only:maxp,maxalpha,maxvxyzu,maxptmass,maxdusttypes,itau_alloc,itauL_alloc,& nalpha,mhd,mhd_nonideal,do_radiation,gravity,use_dust,mpi,do_nucleation,& - use_dustgrowth,ind_timesteps,idumpfile,update_muGamma + use_dustgrowth,ind_timesteps,idumpfile,update_muGamma,use_apr use deriv, only:derivs use evwrite, only:init_evfile,write_evfile,write_evlog use energies, only:compute_energies @@ -138,7 +141,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) maxphase,iphase,isetphase,iamtype,igas,idust,imu,igamma,massoftype, & nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,fxyz_ptmass_sinksink,& epot_sinksink,get_ntypes,isdead_or_accreted,dustfrac,ddustevol,& - nden_nimhd,dustevol,rhoh,gradh, & + nden_nimhd,dustevol,rhoh,gradh,apr_level,aprmassoftype,& Bevol,Bxyz,dustprop,filfac,ddustprop,ndustsmall,iboundary,eos_vars,dvdx, & n_group,n_ingroup,n_sing,nmatrix,group_info,bin_info,isionised use part, only:pxyzu,dens,metrics,rad,radprop,drad,ithick @@ -198,6 +201,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use partinject, only:update_injected_particles use timestep_ind, only:nbinmax #endif + use apr, only:init_apr #ifdef KROME use krome_interface, only:initialise_krome #endif @@ -218,7 +222,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) use units, only:udist,unit_density use centreofmass, only:get_centreofmass use energies, only:etot,angtot,totmom,mdust,xyzcom,mtot - use checkconserved, only:get_conserv,etot_in,angtot_in,totmom_in,mdust_in + use checkconserved, only:get_conserv,etot_in,angtot_in,totmom_in,mdust_in,mtot_in use fileutils, only:make_tags_unique use damping, only:idamp use subgroup, only:group_identify,init_subgroup,update_kappa @@ -364,6 +368,14 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) call error('setup','damping on: setting non-zero velocities to zero') vxyzu(1:3,:) = 0. endif + + ! initialise apr if it is being used + if (use_apr) then + call init_apr(apr_level,ierr) + else + apr_level(:) = 1 + endif + ! !--The code works in B/rho as its conservative variable, but writes B to dumpfile ! So we now convert our primitive variable read, B, to the conservative B/rho @@ -374,7 +386,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) call set_linklist(npart,npart,xyzh,vxyzu) fxyzu = 0. call densityiterate(2,npart,npart,xyzh,vxyzu,divcurlv,divcurlB,Bevol,stressmax,& - fxyzu,fext,alphaind,gradh,rad,radprop,dvdx) + fxyzu,fext,alphaind,gradh,rad,radprop,dvdx,apr_level) endif ! now convert to B/rho @@ -442,7 +454,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) call set_linklist(npart,npart,xyzh,vxyzu) fxyzu = 0. call densityiterate(2,npart,npart,xyzh,vxyzu,divcurlv,divcurlB,Bevol,stressmax,& - fxyzu,fext,alphaind,gradh,rad,radprop,dvdx) + fxyzu,fext,alphaind,gradh,rad,radprop,dvdx,apr_level) endif #ifndef PRIM2CONS_FIRST call init_metric(npart,xyzh,metrics,metricderivs) @@ -536,7 +548,13 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) do i=1,npart if (.not.isdead_or_accreted(xyzh(4,i))) then if (ntypes > 1 .and. maxphase==maxp) then - pmassi = massoftype(iamtype(iphase(i))) + if (use_apr) then + pmassi = aprmassoftype(iamtype(iphase(i)),apr_level(i)) + else + pmassi = massoftype(iamtype(iphase(i))) + endif + else if (use_apr) then + pmassi = aprmassoftype(igas,apr_level(i)) endif if (use_regnbody) then call get_accel_sink_gas(nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),xyzmh_ptmass, & @@ -611,6 +629,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) npart,npart_old,npartoftype,dtinject) call update_injected_particles(npart_old,npart,istepfrac,nbinmax,time,dtmax,dt,dtinject) #endif + ! !--set initial chemical abundance values ! @@ -639,13 +658,13 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) do j=1,nderivinit if (ntot > 0) call derivs(1,npart,npart,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,Bevol,dBevol,& rad,drad,radprop,dustprop,ddustprop,dustevol,ddustevol,filfac,& - dustfrac,eos_vars,time,0.,dtnew_first,pxyzu,dens,metrics) + dustfrac,eos_vars,time,0.,dtnew_first,pxyzu,dens,metrics,apr_level) #ifdef LIVE_ANALYSIS call do_analysis(dumpfile,numfromfile(dumpfile),xyzh,vxyzu, & massoftype(igas),npart,time,ianalysis) call derivs(1,npart,npart,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& Bevol,dBevol,rad,drad,radprop,dustprop,ddustprop,dustevol,& - ddustevol,filfac,dustfrac,eos_vars,time,0.,dtnew_first,pxyzu,dens,metrics) + ddustevol,filfac,dustfrac,eos_vars,time,0.,dtnew_first,pxyzu,dens,metrics,apr_level) if (do_radiation) call set_radiation_and_gas_temperature_equal(npart,xyzh,vxyzu,massoftype,rad) #endif @@ -758,6 +777,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) angtot_in = angtot totmom_in = totmom mdust_in = mdust + mtot_in = mtot if (id==master .and. iverbose >= 1) then write(iprint,'(1x,a)') 'Setting initial values to verify conservation laws:' endif @@ -780,6 +800,9 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) enddo write(iprint,'(1x,a,es18.6)') 'Initial total dust mass:', sum(mdust_in(:)) endif + if (use_apr) then + write(iprint,'(1x,a,es18.6)') 'Initial total mass: ', mtot_in + endif endif ! !--Print warnings of units if values are not reasonable diff --git a/src/main/kdtree.F90 b/src/main/kdtree.F90 index e9a0c9e9f..8c997cc30 100644 --- a/src/main/kdtree.F90 +++ b/src/main/kdtree.F90 @@ -20,10 +20,11 @@ module kdtree ! :Dependencies: allocutils, boundary, dim, dtypekdtree, fastmath, io, ! kernel, mpibalance, mpidomain, mpitree, mpiutils, part, timing ! - use dim, only:maxp,ncellsmax,minpart + use dim, only:maxp,ncellsmax,minpart,use_apr use io, only:nprocs use dtypekdtree, only:kdnode,ndimtree - use part, only:ll,iphase,xyzh_soa,iphase_soa,maxphase,dxi + use part, only:ll,iphase,xyzh_soa,iphase_soa,maxphase,dxi, & + apr_level,apr_level_soa,aprmassoftype implicit none @@ -107,7 +108,7 @@ end subroutine deallocate_kdtree ! -implement revtree routine to update tree w/out rebuilding (done - Sep 2015) !+ !------------------------------------------------------------------------------- -subroutine maketree(node, xyzh, np, ndim, ifirstincell, ncells, refinelevels) +subroutine maketree(node, xyzh, np, ndim, ifirstincell, ncells, apr_tree, refinelevels) use io, only:fatal,warning,iprint,iverbose !$ use omp_lib type(kdnode), intent(out) :: node(:) !ncellsmax+1) @@ -115,6 +116,7 @@ subroutine maketree(node, xyzh, np, ndim, ifirstincell, ncells, refinelevels) real, intent(inout) :: xyzh(:,:) ! inout because of boundary crossing integer, intent(out) :: ifirstincell(:) !ncellsmax+1) integer(kind=8), intent(out) :: ncells + logical, intent(in) :: apr_tree integer, optional, intent(out) :: refinelevels integer :: i,npnode,il,ir,istack,nl,nr,mymum @@ -197,7 +199,7 @@ subroutine maketree(node, xyzh, np, ndim, ifirstincell, ncells, refinelevels) ! construct node call construct_node(node(nnode), nnode, mymum, level, xmini, xmaxi, npnode, .true., & ! construct in parallel il, ir, nl, nr, xminl, xmaxl, xminr, xmaxr, & - ncells, ifirstincell, minlevel, maxlevel, ndim, xyzh, wassplit, .false.) + ncells, ifirstincell, minlevel, maxlevel, ndim, xyzh, wassplit, .false.,apr_tree) if (wassplit) then ! add children to back of queue if (istack+2 > istacksize) call fatal('maketree',& @@ -224,7 +226,7 @@ subroutine maketree(node, xyzh, np, ndim, ifirstincell, ncells, refinelevels) !$omp shared(xyzh) & !$omp shared(np, ndim) & !$omp shared(node, ncells) & - !$omp shared(nqueue) & + !$omp shared(nqueue,apr_tree) & !$omp private(istack) & !$omp private(nnode, mymum, level, npnode, xmini, xmaxi) & !$omp private(ir, il, nl, nr) & @@ -247,7 +249,7 @@ subroutine maketree(node, xyzh, np, ndim, ifirstincell, ncells, refinelevels) ! construct node call construct_node(node(nnode), nnode, mymum, level, xmini, xmaxi, npnode, .false., & ! don't construct in parallel il, ir, nl, nr, xminl, xmaxl, xminr, xmaxr, & - ncells, ifirstincell, minlevel, maxlevel, ndim, xyzh, wassplit, .false.) + ncells, ifirstincell, minlevel, maxlevel, ndim, xyzh, wassplit, .false.,apr_tree) if (wassplit) then ! add children to top of stack if (istack+2 > istacksize) call fatal('maketree',& @@ -346,7 +348,7 @@ subroutine construct_root_node(np,nproot,irootnode,ndim,xmini,xmaxi,ifirstincell nproot = 0 !$omp parallel default(none) & !$omp shared(np,xyzh) & - !$omp shared(inodeparts,iphase,xyzh_soa,iphase_soa,nproot) & + !$omp shared(inodeparts,iphase,xyzh_soa,iphase_soa,nproot,apr_level_soa) & #ifdef PERIODIC !$omp shared(isperiodic) & !$omp reduction(+:ncross) & @@ -387,11 +389,15 @@ subroutine construct_root_node(np,nproot,irootnode,ndim,xmini,xmaxi,ifirstincell else inodeparts(nproot) = -i ! -ve if inactive endif + if (use_apr) inodeparts(nproot) = abs(inodeparts(nproot)) #else inodeparts(nproot) = i #endif xyzh_soa(nproot,:) = xyzh(:,i) iphase_soa(nproot) = iphase(i) + if (use_apr) then + apr_level_soa(nproot) = apr_level(i) + endif endif isnotdead enddo @@ -457,7 +463,7 @@ end subroutine pop_off_stack subroutine construct_node(nodeentry, nnode, mymum, level, xmini, xmaxi, npnode, doparallel,& il, ir, nl, nr, xminl, xmaxl, xminr, xmaxr, & ncells, ifirstincell, minlevel, maxlevel, ndim, xyzh, wassplit, & - global_build) + global_build,apr_tree) use dim, only:maxtypes,mpi use part, only:massoftype,igas,iamtype,maxphase,maxp,npartoftype use io, only:fatal,error @@ -476,6 +482,7 @@ subroutine construct_node(nodeentry, nnode, mymum, level, xmini, xmaxi, npnode, real, intent(in) :: xyzh(:,:) logical, intent(out) :: wassplit logical, intent(in) :: global_build + logical, intent(in) :: apr_tree real :: xyzcofm(ndim) real :: totmass_node @@ -546,14 +553,15 @@ subroutine construct_node(nodeentry, nnode, mymum, level, xmini, xmaxi, npnode, dfac = 1. endif endif + ! note that dfac can be a constant value across all particles even if APR is used i1=inoderange(1,nnode) ! during initial queue build which is serial, we can parallelise this loop if (npnode > 1000 .and. doparallel) then !$omp parallel do schedule(static) default(none) & !$omp shared(maxp,maxphase) & - !$omp shared(npnode,massoftype,dfac) & - !$omp shared(xyzh_soa,i1,iphase_soa) & + !$omp shared(npnode,massoftype,dfac,aprmassoftype) & + !$omp shared(xyzh_soa,apr_level_soa,i1,iphase_soa) & !$omp private(i,xi,yi,zi,hi) & !$omp firstprivate(pmassi,fac) & !$omp reduction(+:xcofm,ycofm,zcofm,totmass_node) & @@ -565,8 +573,15 @@ subroutine construct_node(nodeentry, nnode, mymum, level, xmini, xmaxi, npnode, hi = xyzh_soa(i,4) hmax = max(hmax,hi) if (maxphase==maxp) then - pmassi = massoftype(iamtype(iphase_soa(i))) + if (use_apr) then + pmassi = aprmassoftype(iamtype(iphase_soa(i)),apr_level_soa(i)) + else + pmassi = massoftype(iamtype(iphase_soa(i))) + endif fac = pmassi*dfac ! to avoid round-off error + elseif (use_apr) then + pmassi = aprmassoftype(igas,apr_level_soa(i)) + fac = pmassi*dfac ! to avoid round-off error endif totmass_node = totmass_node + pmassi xcofm = xcofm + fac*xi @@ -582,8 +597,15 @@ subroutine construct_node(nodeentry, nnode, mymum, level, xmini, xmaxi, npnode, hi = xyzh_soa(i,4) hmax = max(hmax,hi) if (maxphase==maxp) then - pmassi = massoftype(iamtype(iphase_soa(i))) + if (use_apr) then + pmassi = aprmassoftype(iamtype(iphase_soa(i)),apr_level_soa(i)) + else + pmassi = massoftype(iamtype(iphase_soa(i))) + endif fac = pmassi*dfac ! to avoid round-off error + elseif (use_apr) then + pmassi = aprmassoftype(igas,apr_level_soa(i)) + fac = pmassi*dfac ! to avoid round-off error endif totmass_node = totmass_node + pmassi xcofm = xcofm + fac*xi @@ -624,10 +646,10 @@ subroutine construct_node(nodeentry, nnode, mymum, level, xmini, xmaxi, npnode, !--compute size of node !!$omp parallel do if (npnode > 1000 .and. doparallel) & !!$omp default(none) schedule(static) & - !!$omp shared(npnode,xyzh_soa,x0,i1) & + !!$omp shared(npnode,xyzh_soa,x0,i1,apr_level_soa) & + !!$omp shared(iphase_soa,massoftype) & !!$omp private(i,xi,yi,zi,dx,dy,dz,dr2,pmassi) & #ifdef GRAVITY - !!$omp shared(iphase_soa,massoftype) & !!$omp reduction(+:quads) & #endif !!$omp reduction(max:r2max) @@ -646,7 +668,11 @@ subroutine construct_node(nodeentry, nnode, mymum, level, xmini, xmaxi, npnode, r2max = max(r2max,dr2) #ifdef GRAVITY if (maxphase==maxp) then - pmassi = massoftype(iamtype(iphase_soa(i))) + if (use_apr) then + pmassi = aprmassoftype(iamtype(iphase_soa(i)),apr_level_soa(i)) + else + pmassi = massoftype(iamtype(iphase_soa(i))) + endif endif quads(1) = quads(1) + pmassi*(3.*dx*dx - dr2) ! Q_xx quads(2) = quads(2) + pmassi*(3.*dx*dy) ! Q_xy = Q_yx @@ -698,6 +724,7 @@ subroutine construct_node(nodeentry, nnode, mymum, level, xmini, xmaxi, npnode, #endif wassplit = (npnodetot > minpart) + if (apr_tree) wassplit = (npnode > 2) if (.not. wassplit) then nodeentry%leftchild = 0 @@ -747,8 +774,16 @@ subroutine construct_node(nodeentry, nnode, mymum, level, xmini, xmaxi, npnode, ifirstincell(nnode) = 0 if (npnode > 0) then - call sort_particles_in_cell(iaxis,inoderange(1,nnode),inoderange(2,nnode),inoderange(1,il),inoderange(2,il),& - inoderange(1,ir),inoderange(2,ir),nl,nr,xpivot,xyzh_soa,iphase_soa,inodeparts) + if (apr_tree) then + ! apr special sort - only used for merging particles + call special_sort_particles_in_cell(iaxis,inoderange(1,nnode),inoderange(2,nnode),inoderange(1,il),inoderange(2,il),& + inoderange(1,ir),inoderange(2,ir),nl,nr,xpivot,xyzh_soa,iphase_soa,inodeparts,& + npnode,apr_level_soa) + else + ! regular sort + call sort_particles_in_cell(iaxis,inoderange(1,nnode),inoderange(2,nnode),inoderange(1,il),inoderange(2,il),& + inoderange(1,ir),inoderange(2,ir),nl,nr,xpivot,xyzh_soa,iphase_soa,inodeparts,apr_level_soa) + endif if (nr + nl /= npnode) then call error('maketree','number of left + right != parent while splitting (likely cause: NaNs in position arrays)') @@ -821,14 +856,14 @@ end subroutine construct_node ! fall to the left or the right of the pivot axis !+ !---------------------------------------------------------------- -subroutine sort_particles_in_cell(iaxis,imin,imax,min_l,max_l,min_r,max_r,nl,nr,xpivot,xyzh_soa,iphase_soa,inodeparts) +subroutine sort_particles_in_cell(iaxis,imin,imax,min_l,max_l,min_r,max_r,nl,nr,xpivot,xyzh_soa,iphase_soa,inodeparts,apr_level_soa) integer, intent(in) :: iaxis,imin,imax integer, intent(out) :: min_l,max_l,min_r,max_r,nl,nr real, intent(inout) :: xpivot,xyzh_soa(:,:) - integer(kind=1), intent(inout) :: iphase_soa(:) + integer(kind=1), intent(inout) :: iphase_soa(:),apr_level_soa(:) integer, intent(inout) :: inodeparts(:) logical :: i_lt_pivot,j_lt_pivot - integer(kind=1) :: iphase_swap + integer(kind=1) :: iphase_swap,apr_swap integer :: inodeparts_swap,i,j real :: xyzh_swap(4) @@ -838,7 +873,8 @@ subroutine sort_particles_in_cell(iaxis,imin,imax,min_l,max_l,min_r,max_r,nl,nr, i_lt_pivot = xyzh_soa(i,iaxis) <= xpivot j_lt_pivot = xyzh_soa(j,iaxis) <= xpivot - ! k = 0 + ! k = 0 + do while(i < j) if (i_lt_pivot) then i = i + 1 @@ -852,14 +888,17 @@ subroutine sort_particles_in_cell(iaxis,imin,imax,min_l,max_l,min_r,max_r,nl,nr, inodeparts_swap = inodeparts(i) xyzh_swap(1:4) = xyzh_soa(i,1:4) iphase_swap = iphase_soa(i) + apr_swap = apr_level_soa(i) inodeparts(i) = inodeparts(j) xyzh_soa(i,1:4) = xyzh_soa(j,1:4) iphase_soa(i) = iphase_soa(j) + apr_level_soa(i)= apr_level_soa(j) inodeparts(j) = inodeparts_swap xyzh_soa(j,1:4) = xyzh_swap(1:4) iphase_soa(j) = iphase_swap + apr_level_soa(j)= apr_swap i = i + 1 j = j - 1 @@ -880,9 +919,190 @@ subroutine sort_particles_in_cell(iaxis,imin,imax,min_l,max_l,min_r,max_r,nl,nr, if ( j /= i+1) print*,' ERROR ',i,j nl = max_l - min_l + 1 nr = max_r - min_r + 1 - + end subroutine sort_particles_in_cell +!---------------------------------------------------------------- +!+ +! Categorise particles into daughter nodes by whether they +! fall to the left or the right of the pivot axis, but additionally +! force the cells to have a certain minimum number of particles per cell +!+ +!---------------------------------------------------------------- +subroutine special_sort_particles_in_cell(iaxis,imin,imax,min_l,max_l,min_r,max_r,& + nl,nr,xpivot,xyzh_soa,iphase_soa,inodeparts,npnode,apr_level_soa) + use io, only:error + integer, intent(in) :: iaxis,imin,imax,npnode + integer, intent(out) :: min_l,max_l,min_r,max_r,nl,nr + real, intent(inout) :: xpivot,xyzh_soa(:,:) + integer(kind=1), intent(inout) :: iphase_soa(:),apr_level_soa(:) + integer, intent(inout) :: inodeparts(:) + logical :: i_lt_pivot,j_lt_pivot,slide_l,slide_r + integer(kind=1) :: iphase_swap,apr_swap + integer :: inodeparts_swap,i,j,nchild_in + integer :: k,ii,rem_nr,rem_nl + real :: xyzh_swap(4),dpivot(npnode) + + dpivot = 0.0 + nchild_in = 2 + + if (modulo(npnode,nchild_in) > 0) then + call error('apr sort','number of particles sent in to kdtree is not divisible by 2') + endif + +! print*,'nnode ',imin,imax,npnode,' pivot = ',iaxis,xpivot + i = imin + j = imax + + i_lt_pivot = xyzh_soa(i,iaxis) <= xpivot + j_lt_pivot = xyzh_soa(j,iaxis) <= xpivot + dpivot(i-imin+1) = xpivot - xyzh_soa(i,iaxis) + dpivot(j-imin+1) = xpivot - xyzh_soa(j,iaxis) + !k = 0 + do while(i < j) + if (i_lt_pivot) then + i = i + 1 + dpivot(i-imin+1) = xpivot - xyzh_soa(i,iaxis) + i_lt_pivot = xyzh_soa(i,iaxis) <= xpivot + else + if (.not.j_lt_pivot) then + j = j - 1 + dpivot(j-imin+1) = xpivot - xyzh_soa(j,iaxis) + j_lt_pivot = xyzh_soa(j,iaxis) <= xpivot + else + ! swap i and j positions in list + inodeparts_swap = inodeparts(i) + xyzh_swap(1:4) = xyzh_soa(i,1:4) + iphase_swap = iphase_soa(i) + apr_swap = apr_level_soa(i) + + inodeparts(i) = inodeparts(j) + xyzh_soa(i,1:4) = xyzh_soa(j,1:4) + iphase_soa(i) = iphase_soa(j) + apr_level_soa(i)= apr_level_soa(j) + + inodeparts(j) = inodeparts_swap + xyzh_soa(j,1:4) = xyzh_swap(1:4) + iphase_soa(j) = iphase_swap + apr_level_soa(j)= apr_swap + + i = i + 1 + j = j - 1 + + dpivot(i-imin+1) = xpivot - xyzh_soa(i,iaxis) + dpivot(j-imin+1) = xpivot - xyzh_soa(j,iaxis) + + i_lt_pivot = xyzh_soa(i,iaxis) <= xpivot + j_lt_pivot = xyzh_soa(j,iaxis) <= xpivot + endif + endif + enddo + + if (.not.i_lt_pivot) then + i = i - 1 + dpivot(i-imin+1) = xpivot - xyzh_soa(i,iaxis) + endif + if (j_lt_pivot) then + j = j + 1 + dpivot(j-imin+1) = xpivot - xyzh_soa(j,iaxis) + endif + + min_l = imin + max_l = i + min_r = j + max_r = imax + + if ( j /= i+1) print*,' ERROR ',i,j + nl = max_l - min_l + 1 + nr = max_r - min_r + 1 + + ! does the pivot need to be adjusted? + rem_nl = modulo(nl,nchild_in) + rem_nr = modulo(nr,nchild_in) + if (rem_nl == 0 .and. rem_nr == 0) return + + ! Decide which direction the pivot needs to go + if (rem_nl < rem_nr) then + slide_l = .true. + slide_r = .false. + else + slide_l = .false. + slide_r = .true. + endif + ! Override this if there's less than nchild*2 in the cell + if (nl < nchild_in) then + slide_r = .true. + slide_l = .false. + elseif (nr < nchild_in) then + slide_r = .false. + slide_l = .true. + endif + + ! Move across particles by distance from xpivot till we get + ! the right number of particles in each cell + if (slide_r) then + do ii = 1,rem_nr + ! next particle to shift across + k = minloc(dpivot,dim=1,mask=dpivot.gt.0.) + imin - 1 + if (k-imin+1==0) k = maxloc(dpivot,dim=1,mask=dpivot.lt.0.) + imin - 1 + + ! swap this with the first particle on the j side + inodeparts_swap = inodeparts(k) + xyzh_swap(1:4) = xyzh_soa(k,1:4) + iphase_swap = iphase_soa(k) + + inodeparts(k) = inodeparts(j) + xyzh_soa(k,1:4) = xyzh_soa(j,1:4) + iphase_soa(k) = iphase_soa(j) + + inodeparts(j) = inodeparts_swap + xyzh_soa(j,1:4) = xyzh_swap(1:4) + iphase_soa(j) = iphase_swap + + ! and now shift to the right + i = i + 1 + j = j + 1 + + ! ditch it, go again + dpivot(k-imin+1) = huge(k-imin+1) + enddo + else + do ii = 1,rem_nl + ! next particle to shift across + k = maxloc(dpivot,dim=1,mask=dpivot.lt.0.) + imin - 1 + if (k-imin+1==0) k = minloc(dpivot,dim=1,mask=dpivot.gt.0.) + imin - 1 + + ! swap this with the last particle on the i side + inodeparts_swap = inodeparts(k) + xyzh_swap(1:4) = xyzh_soa(k,1:4) + iphase_swap = iphase_soa(k) + + inodeparts(k) = inodeparts(i) + xyzh_soa(k,1:4) = xyzh_soa(i,1:4) + iphase_soa(k) = iphase_soa(i) + + inodeparts(i) = inodeparts_swap + xyzh_soa(i,1:4) = xyzh_swap(1:4) + iphase_soa(i) = iphase_swap + + ! and now shift to the left + i = i - 1 + j = j - 1 + + ! ditch it, go again + dpivot(k-imin+1) = huge(k-imin+1) + + enddo + endif + + ! tidy up outputs + max_l = i + min_r = j + nl = max_l - min_l + 1 + nr = max_r - min_r + 1 + +end subroutine special_sort_particles_in_cell + !---------------------------------------------------------------- !+ ! Routine to walk tree for neighbour search @@ -1289,8 +1509,8 @@ subroutine revtree(node, xyzh, ifirstincell, ncells) !$omp parallel default(none) & !$omp shared(maxp,maxphase) & -!$omp shared(xyzh, ifirstincell, ncells) & -!$omp shared(node, ll, iphase, massoftype, maxlevel) & +!$omp shared(xyzh, ifirstincell, ncells, apr_level) & +!$omp shared(node, ll, iphase, massoftype, maxlevel,aprmassoftype) & !$omp private(hmax, r2max, xi, yi, zi, hi, il, ir, nodel, noder) & !$omp private(dx, dy, dz, dr2, icell, i, x0) & #ifdef GRAVITY @@ -1313,7 +1533,11 @@ subroutine revtree(node, xyzh, ifirstincell, ncells) yi = xyzh(2,i) zi = xyzh(3,i) if (maxphase==maxp) then - pmassi = massoftype(iamtype(iphase(i))) + if (use_apr) then + pmassi = aprmassoftype(iamtype(iphase(i)),apr_level(i)) + else + pmassi = massoftype(iamtype(iphase(i))) + endif endif x0(1) = x0(1) + pmassi*xi x0(2) = x0(2) + pmassi*yi @@ -1351,7 +1575,11 @@ subroutine revtree(node, xyzh, ifirstincell, ncells) hmax = max(hi, hmax) #ifdef GRAVITY if (maxphase==maxp) then - pmassi = massoftype(iamtype(iphase(i))) + if (use_apr) then + pmassi = aprmassoftype(iamtype(iphase(i)),apr_level(i)) + else + pmassi = massoftype(iamtype(iphase(i))) + endif endif quads(1) = quads(1) + pmassi*(3.*dx*dx - dr2) quads(2) = quads(2) + pmassi*(3.*dx*dy) @@ -1481,7 +1709,8 @@ end subroutine add_child_nodes ! Routine to build the global level tree !+ !------------------------------------------------------------------------------- -subroutine maketreeglobal(nodeglobal,node,nodemap,globallevel,refinelevels,xyzh,np,ndim,cellatid,ifirstincell,ncells) +subroutine maketreeglobal(nodeglobal,node,nodemap,globallevel,refinelevels,xyzh,& + np,ndim,cellatid,ifirstincell,ncells,apr_tree) use io, only:fatal,warning,id,nprocs use mpiutils, only:reduceall_mpi use mpibalance, only:balancedomains @@ -1499,6 +1728,7 @@ subroutine maketreeglobal(nodeglobal,node,nodemap,globallevel,refinelevels,xyzh, real, intent(inout) :: xyzh(:,:) integer, intent(out) :: cellatid(:) ! ncellsmax+1 integer, intent(out) :: ifirstincell(:) ! ncellsmax+1) + logical, intent(in) :: apr_tree real :: xmini(ndim),xmaxi(ndim) real :: xminl(ndim),xmaxl(ndim) real :: xminr(ndim),xmaxr(ndim) @@ -1543,7 +1773,7 @@ subroutine maketreeglobal(nodeglobal,node,nodemap,globallevel,refinelevels,xyzh, call construct_node(mynode(1), iself, parent, level, xmini, xmaxi, npcounter, .false., & il, ir, nl, nr, xminl, xmaxl, xminr, xmaxr, & ncells, ifirstincell, minlevel, maxlevel, ndim, xyzh, wassplit, & - .true.) + .true.,apr_tree) if (.not.wassplit) then call fatal('maketreeglobal','insufficient particles for splitting at the global level: '// & @@ -1599,11 +1829,15 @@ subroutine maketreeglobal(nodeglobal,node,nodemap,globallevel,refinelevels,xyzh, else inodeparts(npnode) = -i endif + !if (use_apr) inodeparts(npnode) = abs(inodeparts(npnode)) ! Don't think this is necessary anymore #else inodeparts(npnode) = i #endif xyzh_soa(npnode,:) = xyzh(:,i) iphase_soa(npnode) = iphase(i) + if (use_apr) then + apr_level_soa(npnode) = apr_level(i) + endif enddo ! set all particles to belong to this node @@ -1626,7 +1860,7 @@ subroutine maketreeglobal(nodeglobal,node,nodemap,globallevel,refinelevels,xyzh, enddo levels ! local tree - call maketree(node,xyzh,np,ndim,ifirstincell,ncells,refinelevels) + call maketree(node,xyzh,np,ndim,ifirstincell,ncells,apr_tree,refinelevels) ! tree refinement refinelevels = int(reduceall_mpi('min',refinelevels),kind=kind(refinelevels)) diff --git a/src/main/kernel_WendlandC2.f90 b/src/main/kernel_WendlandC2.f90 index 4dd74aa6f..3b1c4f38c 100644 --- a/src/main/kernel_WendlandC2.f90 +++ b/src/main/kernel_WendlandC2.f90 @@ -90,7 +90,7 @@ end subroutine get_kernel_grav1 pure subroutine kernel_softening(q2,q,potensoft,fsoft) real, intent(in) :: q2,q real, intent(out) :: potensoft,fsoft - real :: q4 + real :: q4, q6 if (q < 2.) then q4 = q2*q2 diff --git a/src/main/linklist_kdtree.F90 b/src/main/linklist_kdtree.F90 index 4913f0925..96ea0ea7f 100644 --- a/src/main/linklist_kdtree.F90 +++ b/src/main/linklist_kdtree.F90 @@ -154,7 +154,7 @@ subroutine get_distance_from_centre_of_mass(inode,xi,yi,zi,dx,dy,dz,xcen) end subroutine get_distance_from_centre_of_mass -subroutine set_linklist(npart,nactive,xyzh,vxyzu) +subroutine set_linklist(npart,nactive,xyzh,vxyzu,for_apr) use io, only:nprocs use dtypekdtree, only:ndimtree use kdtree, only:maketree,maketreeglobal @@ -164,11 +164,16 @@ subroutine set_linklist(npart,nactive,xyzh,vxyzu) integer, intent(in) :: nactive real, intent(inout) :: xyzh(:,:) real, intent(in) :: vxyzu(:,:) + logical, optional, intent(in) :: for_apr + logical :: apr_tree + + apr_tree = .false. + if (present(for_apr)) apr_tree = for_apr if (mpi .and. nprocs > 1) then - call maketreeglobal(nodeglobal,node,nodemap,globallevel,refinelevels,xyzh,npart,ndimtree,cellatid,ifirstincell,ncells) + call maketreeglobal(nodeglobal,node,nodemap,globallevel,refinelevels,xyzh,npart,ndimtree,cellatid,ifirstincell,ncells,apr_tree) else - call maketree(node,xyzh,npart,ndimtree,ifirstincell,ncells) + call maketree(node,xyzh,npart,ndimtree,ifirstincell,ncells,apr_tree) endif end subroutine set_linklist diff --git a/src/main/mpi_dens.F90 b/src/main/mpi_dens.F90 index 5948afce0..d588ad26f 100644 --- a/src/main/mpi_dens.F90 +++ b/src/main/mpi_dens.F90 @@ -44,7 +44,8 @@ module mpidens 4 + & ! nneightry 4 * minpart + & ! nneigh(minpart) 4 + & ! waiting_index - 1 * minpart ! iphase(minpart) + 1 * minpart + & ! iphase(minpart) + 1 * minpart ! apr_level type celldens sequence @@ -66,6 +67,7 @@ module mpidens integer :: waiting_index integer(kind=1) :: iphase(minpart) integer(kind=1) :: pad(8 - mod(nbytes_celldens, 8)) + integer(kind=1) :: apr(minpart) ! apr resolution level (not in xpartvec because integer) end type celldens type stackdens @@ -205,6 +207,12 @@ subroutine get_mpitype_of_celldens(dtype) call MPI_GET_ADDRESS(cell%pad,addr,mpierr) disp(nblock) = addr - start + nblock = nblock + 1 + blens(nblock) = size(cell%apr) + mpitypes(nblock) = MPI_INTEGER1 + call MPI_GET_ADDRESS(cell%apr,addr,mpierr) + disp(nblock) = addr - start + call MPI_TYPE_CREATE_STRUCT(nblock,blens(1:nblock),disp(1:nblock),mpitypes(1:nblock),dtype,mpierr) call MPI_TYPE_COMMIT(dtype,mpierr) diff --git a/src/main/mpi_force.F90 b/src/main/mpi_force.F90 index 2fe66c34f..a0a944ec1 100644 --- a/src/main/mpi_force.F90 +++ b/src/main/mpi_force.F90 @@ -45,7 +45,8 @@ module mpiforce 4 + & ! owner 4 + & ! waiting_index 1 * minpart + & ! iphase(minpart) - 1 * minpart ! ibinneigh(minpart) + 1 * minpart + & ! ibinneigh(minpart) + 1 * minpart ! apr_level type cellforce sequence @@ -68,6 +69,7 @@ module mpiforce integer(kind=1) :: iphase(minpart) integer(kind=1) :: ibinneigh(minpart) integer(kind=1) :: pad(8 - mod(nbytes_cellforce, 8)) !padding to maintain alignment of elements + integer(kind=1) :: apr(minpart) ! apr resolution level (not in xpartvec because integer) end type cellforce type stackforce @@ -213,6 +215,12 @@ subroutine get_mpitype_of_cellforce(dtype) call MPI_GET_ADDRESS(cell%pad,addr,mpierr) disp(nblock) = addr - start + nblock = nblock + 1 + blens(nblock) = size(cell%apr) + mpitypes(nblock) = MPI_INTEGER1 + call MPI_GET_ADDRESS(cell%apr,addr,mpierr) + disp(nblock) = addr - start + call MPI_TYPE_CREATE_STRUCT(nblock,blens(1:nblock),disp(1:nblock),mpitypes(1:nblock),dtype,mpierr) call MPI_TYPE_COMMIT(dtype,mpierr) diff --git a/src/main/part.F90 b/src/main/part.F90 index b659e6e8a..e157dd7fa 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -33,7 +33,7 @@ module part maxphase,maxgradh,maxan,maxdustan,maxmhdan,maxneigh,maxprad,maxp_nucleation,& maxTdust,store_dust_temperature,use_krome,maxp_krome, & do_radiation,gr,maxgr,maxgran,n_nden_phantom,do_nucleation,& - inucleation,itau_alloc,itauL_alloc + inucleation,itau_alloc,itauL_alloc,use_apr,apr_maxhard use dtypekdtree, only:kdnode #ifdef KROME use krome_user, only: krome_nmols @@ -296,6 +296,13 @@ module part ! real(kind=4), allocatable :: luminosity(:) ! + +!--APR - we need these arrays whether we use apr or not +! + integer(kind=1), allocatable :: apr_level(:) + integer(kind=1), allocatable :: apr_level_soa(:) +! + !-- Regularisation algorithm allocation ! integer(kind=1), allocatable :: nmatrix(:,:) ! adjacency matrix used to construct each groups @@ -389,7 +396,7 @@ module part integer :: npartoftype(maxtypes) integer(kind=8) :: npartoftypetot(maxtypes) - real :: massoftype(maxtypes) + real :: massoftype(maxtypes),aprmassoftype(maxtypes,apr_maxhard) integer :: ndustsmall,ndustlarge,ndusttypes ! @@ -442,6 +449,8 @@ subroutine allocate_part call allocate_array('dvdx', dvdx, 9, maxp) call allocate_array('divcurlB', divcurlB, ndivcurlB, maxp) call allocate_array('Bevol', Bevol, maxBevol, maxmhd) + call allocate_array('apr_level',apr_level,maxp) + call allocate_array('apr_level_soa',apr_level_soa,maxp) call allocate_array('Bxyz', Bxyz, 3, maxmhd) call allocate_array('iorig', iorig, maxp) call allocate_array('dustprop', dustprop, 2, maxp_growth) @@ -602,6 +611,8 @@ subroutine deallocate_part if (allocated(ibelong)) deallocate(ibelong) if (allocated(istsactive)) deallocate(istsactive) if (allocated(ibin_sts)) deallocate(ibin_sts) + if (allocated(apr_level)) deallocate(apr_level) + if (allocated(apr_level_soa)) deallocate(apr_level_soa) if (allocated(group_info)) deallocate(group_info) if (allocated(bin_info)) deallocate(bin_info) if (allocated(nmatrix)) deallocate(nmatrix) @@ -652,6 +663,7 @@ subroutine init_part ndustsmall = 0 ndustlarge = 0 if (lightcurve) luminosity = 0. + apr_level = 1 ! this is reset if the simulation is to derefine if (do_radiation) then rad(:,:) = 0. radprop(:,:) = 0. @@ -718,6 +730,7 @@ real function get_pmass(i,use_gas) endif end function get_pmass + ! !---------------------------------------------------------------- !+ @@ -1236,6 +1249,9 @@ subroutine copy_particle(src,dst,new_part) dustfrac(:,dst) = dustfrac(:,src) dustevol(:,dst) = dustevol(:,src) endif + if (use_apr) then + apr_level(dst) = apr_level(src) + endif if (maxp_h2==maxp .or. maxp_krome==maxp) abundance(:,dst) = abundance(:,src) eos_vars(:,dst) = eos_vars(:,src) if (store_dust_temperature) dust_temp(dst) = dust_temp(src) @@ -1353,6 +1369,10 @@ subroutine copy_particle_all(src,dst,new_part) istsactive(dst) = istsactive(src) ibin_sts(dst) = ibin_sts(src) endif + if (use_apr) then + apr_level(dst) = apr_level(src) + apr_level_soa(dst) = apr_level_soa(src) + endif if (new_part) then norig = norig + 1 @@ -1571,6 +1591,7 @@ subroutine fill_sendbuf(i,xtemp,nbuf) call fill_buffer(xtemp,twas(i),nbuf) endif call fill_buffer(xtemp,iorig(i),nbuf) + ! call fill_buffer(xtemp,apr_level(i),nbuf) endif if (nbuf > ipartbufsize) call fatal('fill_sendbuf','error: send buffer size overflow',var='nbuf',ival=nbuf) @@ -1656,6 +1677,7 @@ subroutine unfill_buffer(ipart,xbuf) twas(ipart) = unfill_buf(xbuf,j) endif iorig(ipart) = nint(unfill_buf(xbuf,j),kind=8) +! apr_level(ipart) = nint(unfill_buf(xbuf,j),kind=kind(apr_level)) !--just to be on the safe side, set other things to zero if (mhd) then diff --git a/src/main/partinject.F90 b/src/main/partinject.F90 index 8f621fbb3..697a46be1 100644 --- a/src/main/partinject.F90 +++ b/src/main/partinject.F90 @@ -43,12 +43,12 @@ module partinject subroutine add_or_update_particle(itype,position,velocity,h,u,particle_number,npart,npartoftype,xyzh,vxyzu,JKmuS) use part, only:maxp,iamtype,iphase,maxvxyzu,iboundary,nucleation,eos_vars,abundance use part, only:maxalpha,alphaind,maxgradh,gradh,fxyzu,fext,set_particle_type - use part, only:mhd,Bevol,dBevol,Bxyz,divBsymm,gr,pxyzu!,dust_temp + use part, only:mhd,Bevol,dBevol,Bxyz,divBsymm,gr,pxyzu,apr_level use part, only:divcurlv,divcurlB,ndivcurlv,ndivcurlB,ntot,ibin,imu,igamma use part, only:iorig,norig use io, only:fatal use eos, only:gamma,gmw - use dim, only:ind_timesteps,update_muGamma,h2chemistry + use dim, only:ind_timesteps,update_muGamma,h2chemistry,use_apr use timestep_ind, only:nbinmax use cooling_ism, only:abund_default integer, intent(in) :: itype @@ -121,6 +121,8 @@ subroutine add_or_update_particle(itype,position,velocity,h,u,particle_number,np endif if (h2chemistry) abundance(:,particle_number) = abund_default + if (use_apr) apr_level(particle_number) = 1 ! since it has the largest mass + end subroutine add_or_update_particle !----------------------------------------------------------------------- diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 188c56d2f..7c3d6cb92 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -1078,8 +1078,8 @@ end subroutine update_ptmass subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,poten,& massoftype,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,fxyz_ptmass_sinksink,linklist_ptmass,dptmass,time) use part, only:ihacc,ihsoft,itbirth,igas,iamtype,get_partinfo,iphase,iactive,maxphase,rhoh, & - ispinx,ispiny,ispinz,eos_vars,igasP,igamma,ndptmass - use dim, only:maxp,maxneigh,maxvxyzu,maxptmass,ind_timesteps + ispinx,ispiny,ispinz,eos_vars,igasP,igamma,ndptmass,apr_level,aprmassoftype + use dim, only:maxp,maxneigh,maxvxyzu,maxptmass,ind_timesteps,use_apr use kdtree, only:getneigh use kernel, only:kernel_softening,radkern use io, only:id,iprint,fatal,iverbose,nprocs @@ -1256,7 +1256,7 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote #ifdef PERIODIC !$omp shared(dxbound,dybound,dzbound) & #endif -!$omp shared(ibin_wake,ibin_itest) & +!$omp shared(ibin_wake,ibin_itest,apr_level,aprmassoftype) & !$omp private(n,j,xj,yj,zj,hj1,hj21,psoftj,rij2,nk,k,xk,yk,zk,hk1,psoftk,rjk2,psofti,rik2) & !$omp private(dx,dy,dz,dvx,dvy,dvz,dv2,isgasj,isdustj) & !$omp private(rhoj,q2i,qi,fsoft,rcrossvx,rcrossvy,rcrossvz,radxy2,radyz2,radxz2) & @@ -1270,7 +1270,11 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote ! get mass and particle type to immediately determine if active and accretable if (maxphase==maxp) then call get_partinfo(iphase(j),iactivej,isgasj,isdustj,itypej) - pmassj = massoftype(itypej) + if (use_apr) then + pmassj = aprmassoftype(itypej,apr_level(j)) + else + pmassj = massoftype(itypej) + endif if (.not. is_accretable(itypej) ) cycle over_neigh ! Verify particle is 'accretable' endif @@ -1372,7 +1376,11 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote if (k==itest .and. id==id_rhomax) cycle over_neigh_k ! contribution already added if (maxphase==maxp) then itypek = iamtype(iphase(k)) - pmassk = massoftype(itypek) + if (use_apr) then + pmassk = aprmassoftype(itypek,apr_level(k)) + else + pmassk = massoftype(itypek) + endif if (.not. is_accretable(itypek) ) cycle over_neigh_k endif @@ -1596,7 +1604,11 @@ subroutine ptmass_create(nptmass,npart,itest,xyzh,vxyzu,fxyzu,fext,divcurlv,pote j = listneigh(n) if (maxphase==maxp) then itypej = iamtype(iphase(j)) - pmassj = massoftype(itypej) + if (use_apr) then + pmassj = aprmassoftype(itypej,apr_level(j)) + else + pmassj = massoftype(itypej) + endif endif fxj = fxyzu(1,j) + fext(1,j) fyj = fxyzu(2,j) + fext(2,j) @@ -2226,9 +2238,11 @@ end subroutine calculate_mdot !+ !----------------------------------------------------------------------- subroutine ptmass_calc_enclosed_mass(nptmass,npart,xyzh) - use part, only:sink_has_heating,imassenc,ihsoft,massoftype,igas,xyzmh_ptmass,isdead_or_accreted + use part, only:sink_has_heating,imassenc,ihsoft,massoftype,& + igas,xyzmh_ptmass,isdead_or_accreted,aprmassoftype,apr_level use ptmass_heating, only:isink_heating,heating_kernel use kernel, only:radkern2 + use dim, only:use_apr integer, intent(in) :: nptmass,npart real, intent(in) :: xyzh(:,:) integer :: i,j @@ -2253,7 +2267,11 @@ subroutine ptmass_calc_enclosed_mass(nptmass,npart,xyzh) endif enddo !$omp end parallel do - xyzmh_ptmass(imassenc,i) = wi * massoftype(igas) + if (use_apr) then + xyzmh_ptmass(imassenc,i) = wi * aprmassoftype(igas,apr_level(i)) + else + xyzmh_ptmass(imassenc,i) = wi * massoftype(igas) + endif enddo end subroutine ptmass_calc_enclosed_mass diff --git a/src/main/readwrite_dumps_common.f90 b/src/main/readwrite_dumps_common.f90 index f67ae3c05..7451c66c4 100644 --- a/src/main/readwrite_dumps_common.f90 +++ b/src/main/readwrite_dumps_common.f90 @@ -264,14 +264,14 @@ subroutine fill_header(sphNGdump,t,nparttot,npartoftypetot,nblocks,nptmass,hdr,i use options, only:tolh,alpha,alphau,alphaB,iexternalforce,ieos use part, only:massoftype,hfact,Bextx,Bexty,Bextz,ndustsmall,ndustlarge,& idust,grainsize,graindens,ndusttypes - use checkconserved, only:get_conserv,etot_in,angtot_in,totmom_in,mdust_in + use checkconserved, only:get_conserv,etot_in,angtot_in,totmom_in,mdust_in,mtot_in use setup_params, only:rhozero use timestep, only:dtmax_user,idtmax_n_next,idtmax_frac_next,C_cour,C_force use externalforces, only:write_headeropts_extern use boundary, only:xmin,xmax,ymin,ymax,zmin,zmax use boundary_dyn, only:dynamic_bdy,dxyz,rho_bkg_ini,irho_bkg_ini use dump_utils, only:reset_header,add_to_rheader,add_to_header,add_to_iheader,num_in_header,dump_h,maxphead - use dim, only:use_dust,maxtypes,use_dustgrowth,do_nucleation, & + use dim, only:use_dust,maxtypes,use_dustgrowth,do_nucleation,use_apr,& phantom_version_major,phantom_version_minor,phantom_version_micro,periodic,idumpfile use units, only:udist,umass,utime,unit_Bfield use dust_formation, only:write_headeropts_dust_formation @@ -371,6 +371,9 @@ subroutine fill_header(sphNGdump,t,nparttot,npartoftypetot,nblocks,nptmass,hdr,i call add_to_rheader(grainsize(1:ndusttypes),'grainsize',hdr,ierr) call add_to_rheader(graindens(1:ndusttypes),'graindens',hdr,ierr) endif + if (use_apr) then + call add_to_rheader(mtot_in,'mtot_in',hdr,ierr) + endif endif ! real*8 @@ -401,7 +404,7 @@ subroutine unfill_rheader(hdr,phantomdump,ntypesinfile,nptmass,& use options, only:ieos,iexternalforce use part, only:massoftype,Bextx,Bexty,Bextz,mhd,periodic,& maxtypes,grainsize,graindens,ndusttypes - use checkconserved, only:get_conserv,etot_in,angtot_in,totmom_in,mdust_in + use checkconserved, only:get_conserv,etot_in,angtot_in,totmom_in,mdust_in,mtot_in use setup_params, only:rhozero use externalforces, only:read_headeropts_extern,extract_iextern_from_hdr use boundary, only:xmin,xmax,ymin,ymax,zmin,zmax,set_boundary @@ -536,7 +539,8 @@ subroutine unfill_rheader(hdr,phantomdump,ntypesinfile,nptmass,& call extract('etot_in', etot_in, hdr,ierrs(2)) call extract('angtot_in', angtot_in, hdr,ierrs(3)) call extract('totmom_in', totmom_in, hdr,ierrs(4)) - call extract('mdust_in', mdust_in(1:ndusttypes), hdr,ierrs(5)) + call extract('mdust_in', mdust_in(1:ndusttypes), hdr,ierrs(6)) + call extract('mtot_in', mtot_in, hdr,ierrs(5)) if (any(ierrs(1:4) /= 0)) then write(*,*) 'ERROR reading values to verify conservation laws. Resetting initial values.' get_conserv = 1.0 @@ -568,14 +572,14 @@ subroutine check_arrays(i1,i2,noffset,npartoftype,npartread,nptmass,nsinkpropert got_krome_mols,got_krome_gamma,got_krome_mu,got_krome_T, & got_abund,got_dustfrac,got_sink_data,got_sink_vels,got_sink_llist,got_Bxyz,got_psi, & got_dustprop,got_pxyzu,got_VrelVf,got_dustgasprop,got_rad,got_radprop,got_Tdust, & - got_eosvars,got_nucleation,got_iorig,iphase,& - xyzh,vxyzu,pxyzu,alphaind,xyzmh_ptmass,Bevol,iorig,iprint,ierr) + got_eosvars,got_nucleation,got_iorig,got_apr_level,& + iphase,xyzh,vxyzu,pxyzu,alphaind,xyzmh_ptmass,Bevol,iorig,iprint,ierr) use dim, only:maxp,maxvxyzu,maxalpha,maxBevol,mhd,h2chemistry,use_dustgrowth,gr,& - do_radiation,store_dust_temperature,do_nucleation,use_krome,store_ll_ptmass + do_radiation,store_dust_temperature,do_nucleation,use_krome,use_apr,store_ll_ptmass use eos, only:ieos,polyk,gamma,eos_is_non_ideal use part, only:maxphase,isetphase,set_particle_type,igas,ihacc,ihsoft,imacc,ilum,ikappa,& xyzmh_ptmass_label,vxyz_ptmass_label,get_pmass,rhoh,dustfrac,ndusttypes,norig,& - itemp,iX,iZ,imu + itemp,iX,iZ,imu,apr_level use io, only:warning,id,master use options, only:alpha,use_dustfrac,use_var_comp use sphNGutils, only:itype_from_sphNG_iphase,isphNG_accreted @@ -587,7 +591,7 @@ subroutine check_arrays(i1,i2,noffset,npartoftype,npartread,nptmass,nsinkpropert logical, intent(in) :: got_abund(:),got_dustfrac(:),got_sink_data(:),got_sink_vels(:),got_sink_llist,got_Bxyz(:) logical, intent(in) :: got_krome_mols(:),got_krome_gamma,got_krome_mu,got_krome_T logical, intent(in) :: got_psi,got_Tdust,got_eosvars(:),got_nucleation(:),got_pxyzu(:),got_rad(:) - logical, intent(in) :: got_radprop(:),got_iorig + logical, intent(in) :: got_radprop(:),got_iorig,got_apr_level integer(kind=1), intent(inout) :: iphase(:) integer(kind=8), intent(inout) :: iorig(:) real, intent(inout) :: vxyzu(:,:),Bevol(:,:),pxyzu(:,:) @@ -843,6 +847,16 @@ subroutine check_arrays(i1,i2,noffset,npartoftype,npartread,nptmass,nsinkpropert enddo endif +! +! APR +! + if (.not.got_apr_level) then + do i = i1,i2 + apr_level(i) = 1 + enddo + if (id==master .and. i1==1) write(*,"(/,a,/)") 'WARNING: APR levels not in dump; setting to default' + endif + end subroutine check_arrays end module readwrite_dumps_common diff --git a/src/main/readwrite_dumps_fortran.f90 b/src/main/readwrite_dumps_fortran.f90 index 429c6ff32..002645f4c 100644 --- a/src/main/readwrite_dumps_fortran.f90 +++ b/src/main/readwrite_dumps_fortran.f90 @@ -48,7 +48,7 @@ module readwrite_dumps_fortran subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) use dim, only:maxp,maxvxyzu,maxalpha,ndivcurlv,ndivcurlB,maxgrav,gravity,use_dust,& lightcurve,use_dustgrowth,store_dust_temperature,gr,do_nucleation,& - ind_timesteps,mhd_nonideal,use_krome,h2chemistry,update_muGamma,mpi,& + ind_timesteps,mhd_nonideal,use_krome,h2chemistry,update_muGamma,mpi,use_apr,& store_ll_ptmass use eos, only:ieos,eos_is_non_ideal,eos_outputs_mu,eos_outputs_gasP use io, only:idump,iprint,real4,id,master,error,warning,nprocs @@ -62,7 +62,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) VrelVf_label,dustgasprop,dustgasprop_label,filfac,filfac_label,dust_temp,pxyzu,pxyzu_label,dens,& !,dvdx,dvdx_label rad,rad_label,radprop,radprop_label,do_radiation,maxirad,maxradprop,itemp,igasP,igamma,& iorig,iX,iZ,imu,nucleation,nucleation_label,n_nucleation,tau,itau_alloc,tau_lucy,itauL_alloc,& - luminosity,eta_nimhd,eta_nimhd_label + luminosity,eta_nimhd,eta_nimhd_label,apr_level use part, only:metrics,metricderivs,tmunus use options, only:use_dustfrac,use_porosity,use_var_comp,icooling use dump_utils, only:tag,open_dumpfile_w,allocate_header,& @@ -270,6 +270,10 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) call write_array(1,luminosity,'luminosity',npart,k,ipass,idump,nums,nerr) endif + if (use_apr) then + call write_array(1,apr_level,'apr_level',npart,k,ipass,idump,nums,nerr) + endif + if (use_krome) then call write_array(1,abundance,abundance_label,krome_nmols,npart,k,ipass,idump,nums,nerr) call write_array(1,T_gas_cool,'temp',npart,k,ipass,idump,nums,nerr) @@ -356,7 +360,8 @@ end subroutine write_fulldump_fortran !+ !------------------------------------------------------------------- subroutine write_smalldump_fortran(t,dumpfile) - use dim, only:maxp,maxtypes,use_dust,lightcurve,use_dustgrowth,h2chemistry + use dim, only:maxp,maxtypes,use_dust,lightcurve,use_dustgrowth,& + h2chemistry,use_apr use options, only:use_porosity use io, only:idump,iprint,real4,id,master,error,warning,nprocs use part, only:xyzh,xyzh_label,npart,Bxyz,Bxyz_label,& @@ -366,7 +371,7 @@ subroutine write_smalldump_fortran(t,dumpfile) abundance,abundance_label,mhd,dustfrac,iamtype_int11,& dustprop,dustprop_label,dustfrac_label,& filfac,filfac_label,ndusttypes,& - rad,rad_label,do_radiation,maxirad,luminosity + rad,rad_label,do_radiation,maxirad,luminosity,apr_level use dump_utils, only:open_dumpfile_w,dump_h,allocate_header,free_header,& write_header,write_array,write_block_header use mpiutils, only:reduceall_mpi,start_threadwrite,end_threadwrite @@ -449,6 +454,9 @@ subroutine write_smalldump_fortran(t,dumpfile) if (lightcurve) call write_array(1,luminosity,'luminosity',npart,k,ipass,idump,nums,ierr,singleprec=.true.) if (do_radiation) call write_array(1,rad,rad_label,maxirad,npart,k,ipass,idump,nums,ierr,singleprec=.true.) + if (use_apr) then + call write_array(1,apr_level,'apr_level',npart,k,ipass,idump,nums,ierr,func=iamtype_int11) + endif enddo ! !--Block 2 (sinks) @@ -974,7 +982,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto use dump_utils, only:read_array,match_tag use dim, only:use_dust,h2chemistry,maxalpha,maxp,gravity,maxgrav,maxvxyzu,do_nucleation, & use_dustgrowth,maxdusttypes,ndivcurlv,maxphase,gr,store_dust_temperature,& - ind_timesteps,use_krome,store_ll_ptmass + ind_timesteps,use_krome,use_apr,store_ll_ptmass use part, only:xyzh,xyzh_label,vxyzu,vxyzu_label,dustfrac,dustfrac_label,abundance,abundance_label, & alphaind,poten,xyzmh_ptmass,xyzmh_ptmass_label,vxyz_ptmass,vxyz_ptmass_label,linklist_ptmass, & Bevol,Bxyz,Bxyz_label,nabundances,iphase,idust, & @@ -982,7 +990,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto VrelVf,VrelVf_label,dustgasprop,dustgasprop_label,filfac,filfac_label,pxyzu,pxyzu_label,dust_temp, & rad,rad_label,radprop,radprop_label,do_radiation,maxirad,maxradprop,ifluxx,ifluxy,ifluxz, & nucleation,nucleation_label,n_nucleation,ikappa,tau,itau_alloc,tau_lucy,itauL_alloc,& - ithick,ilambda,iorig,dt_in,krome_nmols,T_gas_cool + ithick,ilambda,iorig,dt_in,krome_nmols,T_gas_cool,apr_level use sphNGutils, only:mass_sphng,got_mass,set_gas_particle_mass use options, only:use_porosity integer, intent(in) :: i1,i2,noffset,narraylengths,nums(:,:),npartread,npartoftype(:),idisk1,iprint @@ -998,7 +1006,8 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto logical :: got_krome_mols(krome_nmols),got_krome_T,got_krome_gamma,got_krome_mu logical :: got_eosvars(maxeosvars),got_nucleation(n_nucleation),got_ray_tracer logical :: got_psi,got_Tdust,got_dustprop(2),got_VrelVf,got_dustgasprop(4) - logical :: got_filfac,got_divcurlv(4),got_rad(maxirad),got_radprop(maxradprop),got_pxyzu(4),got_iorig + logical :: got_filfac,got_divcurlv(4),got_rad(maxirad),got_radprop(maxradprop),got_pxyzu(4),& + got_iorig,got_apr_level character(len=lentag) :: tag,tagarr(64) integer :: k,i,iarr,ik,ndustfraci real, allocatable :: tmparray(:) @@ -1035,6 +1044,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto got_radprop = .false. got_pxyzu = .false. got_iorig = .false. + got_apr_level = .false. ndustfraci = 0 if (use_dust) allocate(tmparray(size(dustfrac,2))) @@ -1083,6 +1093,9 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto call read_array(abundance,abundance_label,got_krome_mols,ik,i1,i2,noffset,idisk1,tag,match,ierr) call read_array(T_gas_cool,'temp',got_krome_T,ik,i1,i2,noffset,idisk1,tag,match,ierr) endif + if (use_apr) then + call read_array(apr_level,'apr_level',got_apr_level,ik,i1,i2,noffset,idisk1,tag,match,ierr) + endif if (do_nucleation) then call read_array(nucleation,nucleation_label,got_nucleation,ik,i1,i2,noffset,idisk1,tag,match,ierr) endif @@ -1147,8 +1160,8 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto got_krome_mols,got_krome_gamma,got_krome_mu,got_krome_T, & got_abund,got_dustfrac,got_sink_data,got_sink_vels,got_sink_llist,got_Bxyz, & got_psi,got_dustprop,got_pxyzu,got_VrelVf,got_dustgasprop,got_rad, & - got_radprop,got_Tdust,got_eosvars,got_nucleation,got_iorig,iphase, & - xyzh,vxyzu,pxyzu,alphaind,xyzmh_ptmass,Bevol,iorig,iprint,ierr) + got_radprop,got_Tdust,got_eosvars,got_nucleation,got_iorig, & + got_apr_level,iphase,xyzh,vxyzu,pxyzu,alphaind,xyzmh_ptmass,Bevol,iorig,iprint,ierr) if (.not. phantomdump) then print *, "Calling set_gas_particle_mass" call set_gas_particle_mass(mass_sphng) diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index 450b42f88..520540d1f 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -110,6 +110,7 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) #ifdef INJECT_PARTICLES use inject, only:write_options_inject,inject_type,update_injected_par #endif + use apr, only:write_options_apr use dust_formation, only:write_options_dust_formation use nicil_sup, only:write_options_nicil use metric, only:write_options_metric @@ -120,7 +121,8 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) use gravwaveutils, only:write_options_gravitationalwaves use radiation_utils, only:kappa_cgs use radiation_implicit, only:tol_rad,itsmax_rad,cv_type - use dim, only:maxvxyzu,maxptmass,gravity,sink_radiation,gr,nalpha + use dim, only:maxvxyzu,maxptmass,gravity,sink_radiation,gr,& + nalpha,use_apr use part, only:maxp,mhd,maxalpha,nptmass use boundary_dyn, only:write_options_boundary use HIIRegion, only:write_options_H2R @@ -305,6 +307,11 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) if (gr) call write_options_metric(iwritein) call write_options_gravitationalwaves(iwritein) call write_options_boundary(iwritein) + + if (use_apr) then + write(iwritein,"(/,a)") '# options for adaptive particle refinement' + call write_options_apr(iwritein) + endif call write_options_H2R(iwritein) if (iwritein /= iprint) close(unit=iwritein) @@ -319,7 +326,7 @@ end subroutine write_infile !----------------------------------------------------------------- subroutine read_infile(infile,logfile,evfile,dumpfile) use dim, only:maxvxyzu,maxptmass,gravity,sink_radiation,nucleation,& - itau_alloc,store_dust_temperature,gr,do_nucleation + itau_alloc,store_dust_temperature,gr,do_nucleation,use_apr use timestep, only:tmax,dtmax,nmax,nout,C_cour,C_force,C_ent use eos, only:read_options_eos,ieos use io, only:ireadin,iwritein,iprint,warn,die,error,fatal,id,master,fileprefix @@ -337,6 +344,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) #ifdef INJECT_PARTICLES use inject, only:read_options_inject #endif + use apr, only:read_options_apr use dust_formation, only:read_options_dust_formation,idust_opacity use nicil_sup, only:read_options_nicil use part, only:mhd,nptmass @@ -361,7 +369,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) real :: ratio logical :: imatch,igotallrequired,igotallturb,igotalllink,igotloops logical :: igotallbowen,igotallcooling,igotalldust,igotallextern,igotallinject,igotallgrowth,igotallporosity - logical :: igotallionise,igotallnonideal,igotalleos,igotallptmass,igotalldamping + logical :: igotallionise,igotallnonideal,igotalleos,igotallptmass,igotalldamping,igotallapr logical :: igotallprad,igotalldustform,igotallgw,igotallgr,igotallbdy,igotallH2R integer, parameter :: nrequired = 1 @@ -381,6 +389,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) igotalllink = .true. igotallextern = .true. igotallinject = .true. + igotallapr = .true. igotalleos = .true. igotallcooling = .true. igotalldamping = .true. @@ -556,6 +565,9 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) #ifdef INJECT_PARTICLES if (.not.imatch) call read_options_inject(name,valstring,imatch,igotallinject,ierr) #endif + if (use_apr) then + if (.not.imatch) call read_options_apr(name,valstring,imatch,igotallapr,ierr) + endif if (.not.imatch .and. nucleation) call read_options_dust_formation(name,valstring,imatch,igotalldustform,ierr) if (.not.imatch .and. sink_radiation) then call read_options_ptmass_radiation(name,valstring,imatch,igotallprad,ierr) @@ -589,7 +601,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) .and. igotalleos .and. igotallcooling .and. igotallextern .and. igotallturb & .and. igotallptmass .and. igotallinject .and. igotallionise .and. igotallnonideal & .and. igotallgrowth .and. igotallporosity .and. igotalldamping .and. igotallprad & - .and. igotalldustform .and. igotallgw .and. igotallgr .and. igotallbdy + .and. igotalldustform .and. igotallgw .and. igotallgr .and. igotallbdy .and. igotallapr if (ierr /= 0 .or. ireaderr > 0 .or. .not.igotallrequired) then ierr = 1 @@ -618,6 +630,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) endif endif if (.not.igotallinject) write(*,*) 'missing inject-particle options' + if (.not.igotallapr) write(*,*) 'missing apr options' if (.not.igotallionise) write(*,*) 'missing ionisation options' if (.not.igotallnonideal) write(*,*) 'missing non-ideal MHD options' if (.not.igotallturb) write(*,*) 'missing turbulence-driving options' diff --git a/src/main/relaxem.f90 b/src/main/relaxem.f90 new file mode 100644 index 000000000..38104151c --- /dev/null +++ b/src/main/relaxem.f90 @@ -0,0 +1,249 @@ +!--------------------------------------------------------------------------! +! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! +! Copyright (c) 2007-2023 The Authors (see AUTHORS) ! +! See LICENCE file for usage and distribution conditions ! +! http://phantomsph.github.io/ ! +!--------------------------------------------------------------------------! +module relaxem + ! + ! Routine to shuffle particles towards a reference distribution + ! + ! :References: None + ! + ! :Owner: Rebecca Nealon + ! + ! :Runtime parameters: + ! + ! :Dependencies: timestep, part, kernel, bound, kdtree + ! + implicit none + +contains + +! Subroutine to relax the new set of particles to a reference particle distribution +subroutine relax_particles(npart,n_ref,xyzh_ref,force_ref,nrelax,relaxlist) + use deriv, only:get_derivs_global + integer, intent(in) :: npart,n_ref,nrelax + real, intent(in) :: force_ref(3,n_ref),xyzh_ref(4,n_ref) + integer, intent(in) :: relaxlist(1:nrelax) + real, allocatable :: a_ref(:,:) + real :: ke,maxshift,ke_init,shuffle_tol + logical :: converged + integer :: ishift,nshifts + + write(*,"(/,70('-'),/,/,2x,a,/,/)") 'APR: time to relax ...' + + write(*,"(1x,1(a,i8,a,i8,a))") 'Relaxing',nrelax,' particles the heavenly way from',n_ref,' references.' + + ! Initialise for the loop + converged = .false. + ishift = 0 + nshifts = 50 + shuffle_tol = 0.05 + + ! a_ref stores the accelerations at the locations of the new particles as interpolated from the old ones + allocate(a_ref(3,npart)) + + do while (.not.converged) + + ! This gets fxyz of the new particles at their new locations + call get_derivs_global() + + ! These are the accelerations at the locations of the new particles, interpolated from the parents + call get_reference_accelerations(npart,a_ref,n_ref,xyzh_ref,force_ref,nrelax,relaxlist) + + ! Shift the particles by minimising the difference between the acceleration at the new particles and + ! the interpolated values (i.e. what they do have minus what they should have) + call shift_particles(npart,a_ref,nrelax,relaxlist,ke,maxshift) + + if (ishift == 0) ke_init = ke + + write(*,"(1x,1(a,f5.1,a,i3,a))") 'shuffle decreased to ',ke/ke_init*100.,'% of initial with',ishift,' shifts' + + ! Todo: cut-off criteria + if (ishift >= nshifts .or. (ke/ke_init < shuffle_tol)) converged = .true. + ishift = ishift + 1 + + enddo + + ! Tidy up + deallocate(a_ref) + + write(*,"(/,/,2x,a,/,/,70('-'))") 'APR: relaxing finished.' + +end subroutine relax_particles + +!---------------------------------------------------------------- +!+ +! Interpolates the accelerations at the locations of the new particles +! from the old set of particles (the reference particles) +!+ +!---------------------------------------------------------------- + +subroutine get_reference_accelerations(npart,a_ref,n_ref,xyzh_ref,& + force_ref,nrelax,relaxlist) + use part, only:xyzh,aprmassoftype,igas,apr_level,rhoh + use dim, only:periodic + use kernel, only:wkern,grkern,radkern2,cnormk + use boundary, only:dxbound,dybound,dzbound + integer, intent(in) :: npart,n_ref,nrelax + real, intent(in) :: force_ref(3,n_ref),xyzh_ref(4,n_ref) + integer, intent(in) :: relaxlist(nrelax) + real, intent(out) :: a_ref(3,npart) + real :: xi,yi,zi,rij(3),h21,qj2,rij2,rhoj,h31,mass_ref,pmassi + integer :: i,j,k + + a_ref(:,:) = 0. + + ! Over the new set of particles that are to be shuffled + !$omp parallel do schedule(guided) default (none) & + !$omp shared(xyzh,xyzh_ref,npart,n_ref,force_ref,a_ref,relaxlist) & + !$omp shared(nrelax,apr_level,dxbound,dybound,dzbound) & + !$omp shared(mass_ref,aprmassoftype) & + !$omp private(i,j,xi,yi,zi,rij,h21,h31,rhoj,rij2,qj2,pmassi) + + over_new: do k = 1,nrelax + if (relaxlist(k) == 0) cycle over_new + i = relaxlist(k) + xi = xyzh(1,i) + yi = xyzh(2,i) + zi = xyzh(3,i) + pmassi = aprmassoftype(igas,apr_level(i)) + + ! Over the reference set of particles to which we are matching the accelerations + over_reference: do j = 1,n_ref ! later this should only be over active particles + rij(1) = xyzh_ref(1,j) - xi + rij(2) = xyzh_ref(2,j) - yi + rij(3) = xyzh_ref(3,j) - zi + mass_ref = aprmassoftype(igas,apr_level(j)) ! TBD: fix this to allow for dust + + if (periodic) then + if (abs(rij(1)) > 0.5*dxbound) rij(1) = rij(1) - dxbound*SIGN(1.0,rij(1)) + if (abs(rij(2)) > 0.5*dybound) rij(2) = rij(2) - dybound*SIGN(1.0,rij(2)) + if (abs(rij(3)) > 0.5*dzbound) rij(3) = rij(3) - dzbound*SIGN(1.0,rij(3)) + endif + + h21 = 1./(xyzh_ref(4,j))**2 + h31 = 1./(xyzh_ref(4,j))**3 + rhoj = rhoh(xyzh_ref(4,j),mass_ref) + + rij2 = dot_product(rij,rij) + qj2 = rij2*h21 + + if (qj2 < radkern2) then + ! Interpolate acceleration at the location of the new particle + a_ref(:,i) = a_ref(:,i) + force_ref(:,j)*wkern(qj2,sqrt(qj2))*cnormk*h31/rhoj + endif + + enddo over_reference + enddo over_new + !$omp end parallel do + +end subroutine get_reference_accelerations + +!---------------------------------------------------------------- +!+ +! Calculates the shift for each particle, using the reference +! and interpolated accelerations +! (based off the routine in relax_star) +!+ +!---------------------------------------------------------------- + +subroutine shift_particles(npart,a_ref,nrelax,relaxlist,ke,maxshift) + use dim, only:periodic + use part, only:xyzh,vxyzu,fxyzu,igas,aprmassoftype,rhoh, & + apr_level + use eos, only:get_spsound + use options, only:ieos + use boundary, only:cross_boundary + use mpidomain, only: isperiodic + integer, intent(in) :: npart,nrelax + real, intent(in) :: a_ref(3,npart) + integer, intent(in) :: relaxlist(nrelax) + real, intent(out) :: ke,maxshift + real :: hi,rhoi,cs,dti,dx(3),vi(3),err,pri,limit_bound + real :: pmassi + integer :: nlargeshift,i,ncross,j,m + + ke = 0. + nlargeshift = 0 + ncross = 0 + maxshift = tiny(maxshift) + limit_bound = 0.4 !! This probably shouldn't be more than 0.5 + + !$omp parallel do schedule(guided) default(none) & + !$omp shared(npart,xyzh,vxyzu,fxyzu,ieos,a_ref,maxshift) & + !$omp shared(apr_level,aprmassoftype) & + !$omp shared(isperiodic,ncross,relaxlist,nrelax) & + !$omp private(i,dx,dti,cs,rhoi,hi,vi,err,pri,m,pmassi) & + !$omp reduction(+:nlargeshift,ke) + do j=1,nrelax + if (relaxlist(j) == 0) cycle + i = relaxlist(j) + hi = xyzh(4,i) + pmassi = aprmassoftype(igas,apr_level(i)) + rhoi = rhoh(hi,pmassi) + cs = get_spsound(ieos,xyzh(:,i),rhoi,vxyzu(:,i)) + dti = 0.3*hi/cs ! h/cs + + dx = 0.5*dti**2*(fxyzu(1:3,i) - a_ref(1:3,i)) + if (sqrt(dot_product(dx,dx)) > maxshift) maxshift = sqrt(dot_product(dx,dx)) + if (dot_product(dx,dx) > hi**2) then + + dx = dx / sqrt(dot_product(dx,dx)) * hi ! Avoid large shift in particle position !check with what James has done + nlargeshift = nlargeshift + 1 + endif + + ! actual shift + xyzh(1:3,i) = xyzh(1:3,i) + dx(:) + + ! if periodic, move to the other side of the box + ! (written locally but ideally should call cross_boundary) + if (periodic) call cross_boundary(isperiodic,xyzh(:,i),ncross) + + ! faux velocities, so we can estimate the magnitude of the shift + vi(1:3) = dx(:)/dti + ke = ke + dot_product(vi,vi) + + ! Output for testing purposes + err = sqrt(dot_product(dx,dx))/hi + if (err > maxshift) maxshift = err + + enddo + !$omp end parallel do + if (nlargeshift > 0) print*,'Warning: Restricted dx for ', nlargeshift, 'particles' + + +end subroutine shift_particles + +!---------------------------------------------------------------- +!+ +! For each particle that has been shuffled, check the minimum +! distance between to see if we have any pairing issues +! and specifically, is the shuffling making it worse +!+ +!---------------------------------------------------------------- + +subroutine check_for_pairing(nrelax,relaxlist,pair_distance) + use part, only:xyzh + integer, intent(in) :: nrelax,relaxlist(nrelax) + real, intent(out) :: pair_distance + real :: dx(3), dx_mag + integer :: ii,jj + + pair_distance = huge(pair_distance) + + do ii = 1,nrelax + do jj = 1,nrelax + if (ii == jj) cycle + dx = xyzh(1:3,ii) - xyzh(1:3,jj) + dx_mag = sqrt(dot_product(dx,dx))/xyzh(4,ii) ! scaled by the smoothing length + + if (dx_mag < pair_distance) pair_distance = dx_mag + + enddo + enddo + + end subroutine check_for_pairing + +end module relaxem diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 04ddc2167..a399f495b 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -89,16 +89,16 @@ end subroutine init_step !------------------------------------------------------------ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use dim, only:maxp,ndivcurlv,maxvxyzu,maxptmass,maxalpha,nalpha,h2chemistry,& - use_dustgrowth,use_krome,gr,do_radiation + use_dustgrowth,use_krome,gr,do_radiation,use_apr use io, only:iprint,fatal,iverbose,id,master,warning use options, only:iexternalforce,use_dustfrac,implicit_radiation use part, only:xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,Bevol,dBevol, & rad,drad,radprop,isdead_or_accreted,rhoh,dhdrho,& iphase,iamtype,massoftype,maxphase,igas,idust,mhd,& - iamboundary,get_ntypes,npartoftypetot,& + iamboundary,get_ntypes,npartoftypetot,apr_level,& dustfrac,dustevol,ddustevol,eos_vars,alphaind,nptmass,& dustprop,ddustprop,dustproppred,pxyzu,dens,metrics,ics,& - filfac,filfacpred,mprev,filfacprev,isionised + filfac,filfacpred,mprev,filfacprev,aprmassoftype,isionised use options, only:avdecayconst,alpha,ieos,alphamax use deriv, only:derivs use timestep, only:dterr,bignumber,tolv @@ -143,6 +143,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) logical, parameter :: allow_waking = .true. integer, parameter :: maxits = 30 logical :: converged,store_itype + ! ! set initial quantities ! @@ -231,7 +232,6 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) call check_dustprop(npart,dustprop,filfac,mprev,filfacprev) endif - !---------------------------------------------------------------------- ! substepping with external and sink particle forces, using dtextforce ! accretion onto sinks/potentials also happens during substepping @@ -271,7 +271,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) !$omp parallel do default(none) schedule(guided,1) & !$omp shared(maxp,maxphase,maxalpha) & !$omp shared(xyzh,vxyzu,vpred,fxyzu,divcurlv,npart,store_itype) & -!$omp shared(pxyzu,ppred) & +!$omp shared(pxyzu,ppred,apr_level,aprmassoftype) & !$omp shared(Bevol,dBevol,Bpred,dtsph,massoftype,iphase) & !$omp shared(dustevol,ddustprop,dustprop,dustproppred,dustfrac,ddustevol,dustpred,use_dustfrac) & !$omp shared(filfac,filfacpred,use_porosity) & @@ -287,7 +287,11 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (.not.isdead_or_accreted(xyzh(4,i))) then if (store_itype) then itype = iamtype(iphase(i)) - pmassi = massoftype(itype) + if (use_apr) then + pmassi = aprmassoftype(itype,apr_level(i)) + else + pmassi = massoftype(itype) + endif if (iamboundary(itype)) then if (gr) then ppred(:,i) = pxyzu(:,i) @@ -390,7 +394,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) call derivs(1,npart,nactive,xyzh,vpred,fxyzu,fext,divcurlv,& divcurlB,Bpred,dBevol,radpred,drad,radprop,dustproppred,ddustprop,& dustpred,ddustevol,filfacpred,dustfrac,eos_vars,timei,dtsph,dtnew,& - ppred,dens,metrics) + ppred,dens,metrics,apr_level) if (do_radiation .and. implicit_radiation) then rad = radpred @@ -433,7 +437,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) p2mean = 0. np = 0 itype = igas - pmassi = massoftype(igas) + pmassi = massoftype(igas) ! this does not appear to be used below ntypes = get_ntypes(npartoftypetot) store_itype = (maxphase==maxp .and. ntypes > 1) !$omp parallel default(none) & @@ -679,7 +683,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (gr) vpred = vxyzu ! Need primitive utherm as a guess in cons2prim call derivs(2,npart,nactive,xyzh,vpred,fxyzu,fext,divcurlv,divcurlB, & Bpred,dBevol,radpred,drad,radprop,dustproppred,ddustprop,dustpred,ddustevol,filfacpred,& - dustfrac,eos_vars,timei,dtsph,dtnew,ppred,dens,metrics) + dustfrac,eos_vars,timei,dtsph,dtnew,ppred,dens,metrics,apr_level) if (gr) vxyzu = vpred ! May need primitive variables elsewhere? if (do_radiation .and. implicit_radiation) then rad = radpred diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 6c37b140f..b092b7b2d 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -110,12 +110,13 @@ subroutine substep_sph_gr(dt,npart,xyzh,vxyzu,dens,pxyzu,metrics) end subroutine substep_sph_gr subroutine substep_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,metrics,metricderivs,fext,time) - use dim, only:maxptmass,maxp,maxvxyzu + use dim, only:maxptmass,maxp,maxvxyzu,use_apr use io, only:iverbose,id,master,iprint,warning,fatal use externalforces, only:externalforce,accrete_particles,update_externalforce use options, only:iexternalforce use part, only:maxphase,isdead_or_accreted,iamboundary,igas,iphase,iamtype,& - massoftype,rhoh,ien_type,eos_vars,igamma,itemp,igasP + massoftype,rhoh,ien_type,eos_vars,igamma,itemp,igasP,& + aprmassoftype,apr_level use io_summary, only:summary_variable,iosumextr,iosumextt,summary_accrete use timestep, only:bignumber,C_force,xtol,ptol use eos, only:equationofstate,ieos @@ -183,7 +184,7 @@ subroutine substep_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,metric ! !$omp parallel do default(none) & !$omp shared(npart,xyzh,vxyzu,fext,iphase,ntypes,massoftype) & - !$omp shared(maxphase,maxp,eos_vars) & + !$omp shared(maxphase,maxp,eos_vars,aprmassoftype,apr_level) & !$omp shared(dt,hdt,xtol,ptol) & !$omp shared(ieos,pxyzu,dens,metrics,metricderivs,ien_type) & !$omp private(i,its,spsoundi,tempi,rhoi,hi,eni,uui,densi) & @@ -199,7 +200,13 @@ subroutine substep_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,metric if (.not.isdead_or_accreted(hi)) then if (ntypes > 1 .and. maxphase==maxp) then itype = iamtype(iphase(i)) - pmassi = massoftype(itype) + if (use_apr) then + pmassi = aprmassoftype(itype,apr_level(i)) + else + pmassi = massoftype(itype) + endif + else if (use_apr) then + pmassi = aprmassoftype(igas,apr_level(i)) endif its = 0 @@ -306,7 +313,7 @@ subroutine substep_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,metric dtextforce_min = bignumber !$omp parallel default(none) & !$omp shared(npart,xyzh,metrics,metricderivs,vxyzu,fext,iphase,ntypes,massoftype,hdt,timei) & - !$omp shared(maxphase,maxp) & + !$omp shared(maxphase,maxp,apr_level,aprmassoftype) & !$omp private(i,accreted) & !$omp shared(ieos,dens,pxyzu,iexternalforce,C_force) & !$omp private(pri,pondensi,spsoundi,tempi,dtf) & @@ -319,8 +326,14 @@ subroutine substep_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,metric if (.not.isdead_or_accreted(xyzh(4,i))) then if (ntypes > 1 .and. maxphase==maxp) then itype = iamtype(iphase(i)) - pmassi = massoftype(itype) + if (use_apr) then + pmassi = aprmassoftype(itype,apr_level(i)) + else + pmassi = massoftype(itype) + endif ! if (itype==iboundary) cycle accreteloop + else if (use_apr) then + pmassi = aprmassoftype(igas,apr_level(i)) endif call equationofstate(ieos,pondensi,spsoundi,dens(i),xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) @@ -654,13 +667,14 @@ 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,ndptmass + use part, only:apr_level,aprmassoftype use ptmass, only:f_acc,ptmass_accrete,pt_write_sinkev,update_ptmass,ptmass_kick use externalforces, only:accrete_particles use options, only:iexternalforce use io , only:id,master,fatal,iprint,iverbose use io_summary, only:summary_accrete,summary_accrete_fail use mpiutils, only:bcast_mpi,reduce_in_place_mpi,reduceall_mpi - use dim, only:ind_timesteps,maxp,maxphase + use dim, only:ind_timesteps,maxp,maxphase,use_apr use timestep_sts, only:sts_it_n real, intent(in) :: dt,dki integer, intent(in) :: npart,nptmass,ntypes @@ -734,7 +748,7 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, !$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) & + !$omp shared(xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,f_acc,apr_level,aprmassoftype) & !$omp shared(iexternalforce) & !$omp shared(nbinmax,ibin_wake) & !$omp private(i,accreted,nfaili,fxi,fyi,fzi) & @@ -748,8 +762,14 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, if (.not.isdead_or_accreted(xyzh(4,i))) then if (ntypes > 1 .and. maxphase==maxp) then itype = iamtype(iphase(i)) - pmassi = massoftype(itype) if (iamboundary(itype)) cycle accreteloop + if (use_apr) then + pmassi = aprmassoftype(itype,apr_level(i)) + else + pmassi = massoftype(itype) + endif + else if (use_apr) then + pmassi = aprmassoftype(igas,apr_level(i)) endif ! ! correct v to the full step using only the external force @@ -843,14 +863,14 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, force_count,extf_vdep_flag,linklist_ptmass,bin_info,fsink_old,& group_info,isionised) use io, only:iverbose,master,id,iprint,warning,fatal - use dim, only:maxp,maxvxyzu,itau_alloc + use dim, only:maxp,maxvxyzu,itau_alloc,use_apr use ptmass, only:get_accel_sink_gas,get_accel_sink_sink,merge_sinks, & ptmass_vdependent_correction,n_force_order use options, only:iexternalforce use part, only:maxphase,abundance,nabundances,epot_sinksink,eos_vars,& isdead_or_accreted,iamboundary,igas,iphase,iamtype,massoftype,divcurlv, & fxyz_ptmass_sinksink,dsdt_ptmass_sinksink,dust_temp,tau,& - nucleation,idK2,idmu,idkappa,idgamma,imu,igamma + nucleation,idK2,idmu,idkappa,idgamma,imu,igamma,apr_level,aprmassoftype use cooling_ism, only:dphot0,dphotflag,abundsi,abundo,abunde,abundc,nabn use timestep, only:bignumber,C_force use mpiutils, only:bcast_mpi,reduce_in_place_mpi,reduceall_mpi @@ -980,7 +1000,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, !$omp shared(maxp,maxphase,wsub) & !$omp shared(npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,fext) & !$omp shared(eos_vars,dust_temp,idamp,damp_fac,abundance,iphase,ntypes,massoftype) & - !$omp shared(dkdt,dt,timei,iexternalforce,extf_vdep_flag,last) & + !$omp shared(dkdt,dt,timei,iexternalforce,extf_vdep_flag,last,aprmassoftype,apr_level) & !$omp shared(divcurlv,dphotflag,dphot0,nucleation,extrap) & !$omp shared(abundc,abundo,abundsi,abunde,extrapfac,fsink_old) & !$omp shared(isink_radiation,itau_alloc,tau,isionised) & @@ -995,7 +1015,11 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, if (.not.isdead_or_accreted(xyzh(4,i))) then if (ntypes > 1 .and. maxphase==maxp) then itype = iamtype(iphase(i)) - pmassi = massoftype(itype) + if (use_apr) then + pmassi = aprmassoftype(itype,apr_level(i)) + else + pmassi = massoftype(itype) + endif endif fextx = 0. fexty = 0. diff --git a/src/main/utils_shuffleparticles.F90 b/src/main/utils_shuffleparticles.F90 index 4d519b273..21f57473b 100644 --- a/src/main/utils_shuffleparticles.F90 +++ b/src/main/utils_shuffleparticles.F90 @@ -70,7 +70,7 @@ subroutine shuffleparticles(iprint,npart,xyzh,pmass,duniform,rsphere,dsphere,dme use io, only:id,master,fatal use dim, only:maxneigh,maxp_hard use part, only:vxyzu,divcurlv,divcurlB,Bevol,fxyzu,fext,alphaind,iphase,igas - use part, only:gradh,rad,radprop,dvdx,rhoh,hrho + use part, only:gradh,rad,radprop,dvdx,rhoh,hrho,apr_level use densityforce, only:densityiterate use linklist, only:ncells,ifirstincell,set_linklist,get_neighbour_list,allocate_linklist,listneigh use kernel, only:cnormk,wkern,grkern,radkern2 @@ -300,7 +300,7 @@ subroutine shuffleparticles(iprint,npart,xyzh,pmass,duniform,rsphere,dsphere,dme link_shift = 0. endif call densityiterate(2,npart,npart,xyzh,vxyzu,divcurlv,divcurlB,Bevol,stressmax,& - fxyzu,fext,alphaind,gradh,rad,radprop,dvdx) + fxyzu,fext,alphaind,gradh,rad,radprop,dvdx,apr_level) if (iprofile==ireference) then call set_linklist(n_part,n_part,xyzh,vxyzu) endif diff --git a/src/main/writeheader.F90 b/src/main/writeheader.F90 index a7b5ff448..9361aeb6f 100644 --- a/src/main/writeheader.F90 +++ b/src/main/writeheader.F90 @@ -76,7 +76,7 @@ end subroutine write_codeinfo !----------------------------------------------------------------- subroutine write_header(icall,infile,evfile,logfile,dumpfile,ntot) use dim, only:maxp,maxvxyzu,maxalpha,ndivcurlv,mhd_nonideal,nalpha,use_dust,& - use_dustgrowth,gr,h2chemistry + use_dustgrowth,gr,h2chemistry,use_apr use io, only:iprint use boundary, only:xmin,xmax,ymin,ymax,zmin,zmax use boundary_dyn, only:dynamic_bdy,rho_thresh_bdy,width_bkg @@ -142,6 +142,7 @@ subroutine write_header(icall,infile,evfile,logfile,dumpfile,ntot) enddo write(iprint,"(a)") " " endif + if (use_apr) write(iprint,"(1x,a)") 'Adapative particle refinement is ON' if (periodic) then write(iprint,"(1x,a)") 'Periodic boundaries: ' if (abs(xmin) > 1.0d4 .or. abs(xmax) > 1.0d4 .or. & diff --git a/src/setup/relax_star.f90 b/src/setup/relax_star.f90 index a4bb589ec..cb502c4fc 100644 --- a/src/setup/relax_star.f90 +++ b/src/setup/relax_star.f90 @@ -58,8 +58,8 @@ module relaxstar subroutine relax_star(nt,rho,pr,r,npart,xyzh,use_var_comp,Xfrac,Yfrac,mu,ierr,npin,label) use table_utils, only:yinterp use deriv, only:get_derivs_global - use dim, only:maxp,maxvxyzu,gr,gravity - use part, only:vxyzu,rad,eos_vars,massoftype,igas + use dim, only:maxp,maxvxyzu,gr,gravity,use_apr + use part, only:vxyzu,rad,eos_vars,massoftype,igas,apr_level,fxyzu use step_lf_global, only:init_step,step use initial, only:initialise use memory, only:allocate_memory @@ -73,6 +73,8 @@ subroutine relax_star(nt,rho,pr,r,npart,xyzh,use_var_comp,Xfrac,Yfrac,mu,ierr,np use options, only:iexternalforce use io_summary, only:summary_initialise use setstar_utils, only:set_star_thermalenergy,set_star_composition + use apr, only:init_apr,update_apr + use linklist, only:allocate_linklist integer, intent(in) :: nt integer, intent(inout) :: npart real, intent(in) :: rho(nt),pr(nt),r(nt) @@ -141,6 +143,15 @@ subroutine relax_star(nt,rho,pr,r,npart,xyzh,use_var_comp,Xfrac,Yfrac,mu,ierr,np call warning('relax_star','asynchronous shifting not implemented with external forces: evolving in time instead') use_step = .true. endif + + ! if using apr, options set in setup file but needs to be initialised here + if (use_apr) then + call allocate_linklist + call init_apr(apr_level,ierr) + call update_apr(npart,xyzh,vxyzu,fxyzu,apr_level) + endif + + ! ! define utherm(r) based on P(r) and rho(r) ! and use this to set the thermal energy of all particles @@ -176,7 +187,7 @@ subroutine relax_star(nt,rho,pr,r,npart,xyzh,use_var_comp,Xfrac,Yfrac,mu,ierr,np return endif if (id==master) print "(/,3(a,1pg11.3),/,a,1pg11.3,a,i4)",& - ' RELAX-A-STAR-O-MATIC: Etherm:',etherm,' Epot:',Epot, ' R*:',maxval(r), & + ' s-STAR-O-MATIC: Etherm:',etherm,' Epot:',Epot, ' R*:',maxval(r), & ' WILL stop when Ekin/Epot < ',tol_ekin,' OR Iter=',maxits if (write_files) then @@ -204,6 +215,8 @@ subroutine relax_star(nt,rho,pr,r,npart,xyzh,use_var_comp,Xfrac,Yfrac,mu,ierr,np else call shift_particles(i1,npart,xyzh,vxyzu,dt) endif + ! if using apr, update here + if (use_apr) call update_apr(npart,xyzh,vxyzu,fxyzu,apr_level) ! ! reset thermal energy and calculate information ! @@ -299,13 +312,15 @@ end subroutine relax_star subroutine shift_particles(i1,npart,xyzh,vxyzu,dtmin) use deriv, only:get_derivs_global use part, only:fxyzu,fext,xyzmh_ptmass,nptmass,rhoh,massoftype,igas + use part, only:aprmassoftype,apr_level use ptmass,only:get_accel_sink_gas use eos, only:get_spsound use options, only:ieos + use dim, only:use_apr integer, intent(in) :: i1,npart real, intent(inout) :: xyzh(:,:), vxyzu(:,:) real, intent(out) :: dtmin - real :: dx(3),dti,phi,rhoi,cs,hi + real :: dx(3),dti,phi,rhoi,cs,hi,pmassi integer :: i,nlargeshift ! ! shift particles asynchronously @@ -314,7 +329,8 @@ subroutine shift_particles(i1,npart,xyzh,vxyzu,dtmin) nlargeshift = 0 !$omp parallel do schedule(guided) default(none) & !$omp shared(i1,npart,xyzh,vxyzu,fxyzu,fext,xyzmh_ptmass,nptmass,massoftype,ieos) & - !$omp private(i,dx,dti,phi,cs,rhoi,hi) & + !$omp shared(apr_level,aprmassoftype) & + !$omp private(i,dx,dti,phi,cs,rhoi,hi,pmassi) & !$omp reduction(min:dtmin) & !$omp reduction(+:nlargeshift) do i=i1+1,npart @@ -324,7 +340,12 @@ subroutine shift_particles(i1,npart,xyzh,vxyzu,dtmin) xyzmh_ptmass,fext(1,i),fext(2,i),fext(3,i),phi) endif hi = xyzh(4,i) - rhoi = rhoh(hi,massoftype(igas)) + if (use_apr) then + pmassi = aprmassoftype(igas,apr_level(i)) + else + pmassi = massoftype(igas) + endif + rhoi = rhoh(hi,pmassi) cs = get_spsound(ieos,xyzh(:,i),rhoi,vxyzu(:,i)) dti = 0.3*hi/cs ! h/cs dx = 0.5*dti**2*(fxyzu(1:3,i) + fext(1:3,i)) @@ -356,41 +377,74 @@ subroutine reset_u_and_get_errors(i1,npart,xyzh,vxyzu,rad,nt,mr,rho,& utherm,entrop,fix_entrop,rmax,rmserr) use table_utils, only:yinterp use sortutils, only:find_rank,r2func - use part, only:rhoh,massoftype,igas,maxvxyzu,iorder=>ll - use dim, only:do_radiation + use part, only:rhoh,massoftype,igas,maxvxyzu,ll + use part, only:apr_level,aprmassoftype + use dim, only:do_radiation,use_apr use eos, only:gamma integer, intent(in) :: i1,npart,nt real, intent(in) :: xyzh(:,:),mr(nt),rho(nt),utherm(nt),entrop(nt) real, intent(inout) :: vxyzu(:,:),rad(:,:) real, intent(out) :: rmax,rmserr logical, intent(in) :: fix_entrop - real :: ri,rhor,rhoi,rho1,mstar,massri - integer :: i + real :: rj,rhor,rhoj,rho1,mstar,massrj,pmassj + integer :: i,j,rankj,rank_prev,npart_with_rank_prev + integer, allocatable :: iorder(:) + logical, allocatable :: iorder_mask(:) rho1 = yinterp(rho,mr,0.) rmax = 0. rmserr = 0. + ll = 0 ! this reassignment without changing length is essential for apr + allocate(iorder(npart-i1)) call find_rank(npart-i1,r2func,xyzh(1:3,i1+1:npart),iorder) + ll(1:npart-i1) = iorder(1:npart-i1) + mstar = mr(nt) + allocate(iorder_mask(size(iorder))) + iorder_mask = .true. + rank_prev = 0 + massrj = 0. + do i = i1+1,npart - ri = sqrt(dot_product(xyzh(1:3,i),xyzh(1:3,i))) - massri = mstar * real(iorder(i-i1)-1) / real(npart-i1) - !if (i1 > 0 .and. i-i1 < 10) print*,' r= ',ri,' massri=',massri,iorder(i-i1),npart-i1 - rhor = yinterp(rho,mr,massri) ! analytic rho(r) - rhoi = rhoh(xyzh(4,i),massoftype(igas)) ! actual rho + if (use_apr) then + rankj = minval(iorder,mask=iorder_mask) ! Start from innermost to outermost particles + j = sum(minloc(iorder,mask=iorder_mask)) ! ID of first particle with iorder==rankj. Ignore the sum, doesn't do anything in practice. + iorder_mask(j) = .false. ! Eliminate this particle from next loop + npart_with_rank_prev = count(iorder==rank_prev) ! note that this is 0 for rankj=1 + pmassj = aprmassoftype(igas,apr_level(j)) ! replace with actual particle mass + else + j = i + pmassj = massoftype(igas) ! replace with actual particle mass + endif + + rj = sqrt(dot_product(xyzh(1:3,j),xyzh(1:3,j))) + + if (use_apr) then + if (rankj/=rank_prev) massrj = massrj + real(npart_with_rank_prev)*pmassj ! for rankj=1, this correctly gives 0 + rank_prev = rankj + else + massrj = mstar * real(iorder(i-i1)-1) / real(npart-i1) + endif + ! print*,'rankj=',rankj,'rank_prev=',rank_prev,'npartwithrankprev=',npart_with_rank_prev,'rj=',rj,'massri/pmass=',massrj/pmassj + ! read* + + rhor = yinterp(rho,mr,massrj) ! analytic rho(r) + rhoj = rhoh(xyzh(4,j),pmassj) ! actual rho if (maxvxyzu >= 4) then if (fix_entrop) then - vxyzu(4,i) = (yinterp(entrop,mr,massri)*rhoi**(gamma-1.))/(gamma-1.) + vxyzu(4,j) = (yinterp(entrop,mr,massrj)*rhoj**(gamma-1.))/(gamma-1.) else - vxyzu(4,i) = yinterp(utherm,mr,massri) + vxyzu(4,j) = yinterp(utherm,mr,massrj) endif endif - rmserr = rmserr + (rhor - rhoi)**2 - rmax = max(rmax,ri) + rmserr = rmserr + (rhor - rhoj)**2 + rmax = max(rmax,rj) enddo if (do_radiation) rad = 0. rmserr = sqrt(rmserr/npart)/rho1 + deallocate(iorder,iorder_mask) + end subroutine reset_u_and_get_errors !---------------------------------------------------------------- diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index 4be4dbe7e..eac6dedf8 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -398,7 +398,7 @@ subroutine set_star_thermalenergy(ieos,den,pres,r,npts,npart,xyzh,vxyzu,rad,eos_ integer :: i1 i1 = 0 - eni = 0. + eni = 0. ! to prevent compiler warning if (present(npin)) i1 = npin ! starting position in particle array if (do_radiation) then diff --git a/src/setup/setup_asteroidwind.f90 b/src/setup/setup_asteroidwind.f90 index 6a34c93b4..80cba105c 100644 --- a/src/setup/setup_asteroidwind.f90 +++ b/src/setup/setup_asteroidwind.f90 @@ -27,6 +27,7 @@ module setup ! - npart_at_end : *number of particles injected after norbits* ! - rinject : *radius of asteroid (km)* ! - semia : *semi-major axis (solar radii)* +! - mdot : *rate of mass to be injected (g/s)* ! ! :Dependencies: eos, extern_lensethirring, externalforces, infile_utils, ! inject, io, kernel, options, part, physcon, setbinary, spherical, @@ -54,7 +55,6 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, mass1,accradius1 use io, only:master,fatal use timestep, only:tmax,dtmax - !use inject, only:inject_particles use eos, only:gmw use options, only:iexternalforce use extern_lensethirring, only:blackhole_spin diff --git a/src/setup/setup_star.f90 b/src/setup/setup_star.f90 index e6fa4a8eb..1d5d7b039 100644 --- a/src/setup/setup_star.f90 +++ b/src/setup/setup_star.f90 @@ -248,12 +248,13 @@ end subroutine setup_interactive !----------------------------------------------------------------------- subroutine write_setupfile(filename,gamma,polyk) use infile_utils, only:write_inopt - use dim, only:tagline + use dim, only:tagline,use_apr use relaxstar, only:write_options_relax use eos, only:X_in,Z_in,gmw use eos_gasradrec, only:irecomb use setstar, only:write_options_star,need_polyk use setunits, only:write_options_units + use apr, only:write_options_apr real, intent(in) :: gamma,polyk character(len=*), intent(in) :: filename integer, parameter :: iunit = 20 @@ -301,6 +302,11 @@ subroutine write_setupfile(filename,gamma,polyk) call write_inopt(write_rho_to_file,'write_rho_to_file','write density profile(s) to file',iunit) + if (use_apr) then + write(iunit,"(/,a)") '# apr options' + call write_options_apr(iunit) + endif + close(iunit) end subroutine write_setupfile @@ -318,6 +324,8 @@ subroutine read_setupfile(filename,gamma,polyk,need_iso,ierr) use eos_gasradrec, only:irecomb use setstar, only:read_options_star use setunits, only:read_options_and_set_units + use apr, only:apr_max_in,ref_dir,apr_type,apr_rad,apr_drad + use dim, only:use_apr character(len=*), intent(in) :: filename integer, parameter :: lu = 21 integer, intent(out) :: need_iso,ierr @@ -376,6 +384,14 @@ subroutine read_setupfile(filename,gamma,polyk,need_iso,ierr) ierr = 1 endif + if (use_apr) then + call read_inopt(apr_max_in,'apr_max',db) + call read_inopt(ref_dir,'ref_dir',db) + call read_inopt(apr_type,'apr_type',db) + call read_inopt(apr_rad,'apr_rad',db) + call read_inopt(apr_drad,'apr_drad',db) + endif + call close_db(db) end subroutine read_setupfile diff --git a/src/setup/setup_wave.f90 b/src/setup/setup_wave.f90 index 3a0816ee0..7450aaee5 100644 --- a/src/setup/setup_wave.f90 +++ b/src/setup/setup_wave.f90 @@ -44,6 +44,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use dust, only:K_code,idrag use set_dust, only:set_dustfrac use mpidomain, only:i_belong + use random, only:ran2 integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) @@ -54,7 +55,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, real, intent(inout) :: time character(len=20), intent(in) :: fileprefix real :: totmass,fac,deltax,deltay,deltaz - integer :: i + integer :: i, iseed=4 integer :: itype,itypes,ntypes,npartx integer :: npart_previous,dust_method logical, parameter :: ishift_box =.true. @@ -68,13 +69,14 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! npartx = 64 ntypes = 1 - rhozero = 1. + rhozero = 1.5 !1. massfac = 1. - cs = 1. - ampl = 1.d-4 + cs = 1.0 !2.236 !1. + ampl = 2.d-2 use_dustfrac = .false. ndustsmall = 0 ndustlarge = 0 + if (id==master) then itype = 1 print "(/,a,/)",' >>> Setting up particles for linear wave test <<<' @@ -108,15 +110,15 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! ! boundaries ! - xmini = -0.5 - xmaxi = 0.5 + xmini = 0. + xmaxi = 1.0 length = xmaxi - xmini deltax = length/npartx ! try to give y boundary that is a multiple of 6 particle spacings in the low density part fac = 6.*(int((1.-epsilon(0.))*radkern/6.) + 1) deltay = fac*deltax*sqrt(0.75) deltaz = fac*deltax*sqrt(6.)/3. - call set_boundary(xmini,xmaxi,-deltay,deltay,-deltaz,deltaz) + call set_boundary(xmini,xmaxi,xmini,deltay,-deltaz,deltaz) ! ! general parameters ! @@ -211,6 +213,13 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, dustfrac(:,i) = 0. endif endif + +! +!--add a little perturbation to fake some noise +! +! xyzh(1,i) = xyzh(1,i) + 0.0001*(ran2(iseed)-0.5) +! xyzh(2,i) = xyzh(2,i) + 0.0001*(ran2(iseed)-0.5) + enddo npartoftype(itype) = npart - npart_previous diff --git a/src/tests/directsum.f90 b/src/tests/directsum.f90 index c99024b0c..2a1c5b720 100644 --- a/src/tests/directsum.f90 +++ b/src/tests/directsum.f90 @@ -48,8 +48,9 @@ module directsum subroutine directsum_grav(xyzh,gradh,fgrav,phitot,ntot) use kernel, only:grkern,kernel_softening,radkern2,cnormk use part, only:igas,iamtype,maxphase,maxp,iphase, & - iactive,isdead_or_accreted,massoftype,maxgradh - use dim, only:maxvxyzu,maxp + iactive,isdead_or_accreted,massoftype,maxgradh, & + apr_level,aprmassoftype + use dim, only:maxvxyzu,maxp,use_apr use io, only:error integer, intent(in) :: ntot real, intent(in) :: xyzh(4,ntot) @@ -96,7 +97,13 @@ subroutine directsum_grav(xyzh,gradh,fgrav,phitot,ntot) if (maxphase==maxp) then iamtypei = iamtype(iphase(i)) iactivei = iactive(iphase(i)) - pmassi = massoftype(iamtypei) + if (use_apr) then + pmassi = aprmassoftype(iamtypei,apr_level(i)) + else + pmassi = massoftype(iamtypei) + endif + else + if (use_apr) pmassi = aprmassoftype(igas,apr_level(i)) endif hi1 = 1./hi diff --git a/src/tests/test_apr.f90 b/src/tests/test_apr.f90 new file mode 100644 index 000000000..965d653a4 --- /dev/null +++ b/src/tests/test_apr.f90 @@ -0,0 +1,123 @@ +!--------------------------------------------------------------------------! +! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! +! Copyright (c) 2007-2023 The Authors (see AUTHORS) ! +! See LICENCE file for usage and distribution conditions ! +! http://phantomsph.github.io/ ! +!--------------------------------------------------------------------------! +module testapr +! +! Unit test for adaptive particle refinement +! +! :References: +! +! :Owner: Rebecca Nealon +! +! :Runtime parameters: None +! +! :Dependencies: apr, apr_region, linklist +! + use testutils, only:checkval,update_test_scores + use io, only:id,master + implicit none + public :: test_apr,setup_apr_region_for_test + + private + +contains + +!-------------------------------------------- +!+ +! Various tests of the apr module +!+ +!-------------------------------------------- +subroutine test_apr(ntests,npass) + use physcon, only:solarm,kpc + use units, only:set_units + use unifdis, only:set_unifdis + use io, only:id,master,fatal + use boundary, only:dxbound,dybound,dzbound,xmin,xmax,ymin,ymax,zmin,zmax + use part, only:npart,npartoftype,hfact,xyzh,init_part,massoftype + use part, only:isetphase,igas,iphase,vxyzu,fxyzu,apr_level + use mpidomain, only:i_belong + use mpiutils, only:reduceall_mpi + use dim, only:periodic,use_apr + use apr, only:apr_centre,update_apr + integer, intent(inout) :: ntests,npass + real :: psep,rhozero,time,totmass + integer :: original_npart,splitted + + if (use_apr) then + if (id==master) write(*,"(/,a)") '--> TESTING APR MODULE' + else + if (id==master) write(*,"(/,a)") '--> SKIPPING APR TEST (REQUIRES -DAPR)' + return + endif + + ntests = 1 + + ! Set up a uniform box of particles + call init_part() + psep = dxbound/20. + time = 0. + npartoftype(:) = 0 + npart = 0 + rhozero = 1.0 + totmass = rhozero*dxbound*dybound*dzbound + call set_unifdis('cubic',id,master,xmin,xmax,ymin,ymax,zmin,zmax,psep,& + hfact,npart,xyzh,periodic,mask=i_belong) + + original_npart = npart + massoftype(1) = totmass/reduceall_mpi('+',npart) + iphase(1:npart) = isetphase(igas,iactive=.true.) + + ! Now set up an APR zone + call setup_apr_region_for_test() + + ! after splitting, the total number of particles should have been updated + splitted = npart + + ! Move the apr zone out of the box and update again to merge + apr_centre(:) = 20. + call update_apr(npart,xyzh,vxyzu,fxyzu,apr_level) + + ! Check that the original particle number returns + if (npart == original_npart) then + npass = 1 + else + npass = 0 + endif + + if (id==master) write(*,"(/,a)") '<-- APR TEST COMPLETE' + +end subroutine test_apr + +!-------------------------------------------- +!+ +! Set up an APR region that is used in other tests +!+ +!-------------------------------------------- +subroutine setup_apr_region_for_test() + use apr, only:init_apr,update_apr,apr_max_in,ref_dir + use apr, only:apr_type,apr_rad + use part, only:npart,xyzh,vxyzu,fxyzu,apr_level + use linklist, only:set_linklist + !real :: ratesq(nrates) + integer :: ierr + + if (id==master) write(*,"(/,a)") '--> adding an apr region' + + ! set parameters for the region + apr_max_in = 1 ! number of additional refinement levels (3 -> 2x resolution) + ref_dir = 1 ! increase (1) or decrease (-1) resolution + apr_type = -1 ! choose this so you get the default option which is + ! reserved for the test suite + apr_rad = 0.25 ! radius of innermost region + + + ! initialise + call init_apr(apr_level,ierr) + call update_apr(npart,xyzh,vxyzu,fxyzu,apr_level) + +end subroutine setup_apr_region_for_test + +end module testapr diff --git a/src/tests/test_derivs.F90 b/src/tests/test_derivs.F90 index 271f8ccec..cd24aa515 100644 --- a/src/tests/test_derivs.F90 +++ b/src/tests/test_derivs.F90 @@ -31,7 +31,7 @@ module testderivs subroutine test_derivs(ntests,npass,string) use dim, only:maxp,maxvxyzu,maxalpha,maxdvdx,ndivcurlv,nalpha,use_dust,& - maxdustsmall,periodic,mpi,ind_timesteps + maxdustsmall,periodic,mpi,ind_timesteps,use_apr use boundary, only:dxbound,dybound,dzbound,xmin,xmax,ymin,ymax,zmin,zmax use eos, only:polyk,gamma,init_eos use io, only:iprint,id,master,fatal,iverbose,nprocs @@ -42,7 +42,8 @@ subroutine test_derivs(ntests,npass,string) divcurlv,divcurlB,maxgradh,gradh,divBsymm,Bevol,dBevol,& Bxyz,Bextx,Bexty,Bextz,alphaind,maxphase,rhoh,mhd,& maxBevol,ndivcurlB,dvdx,dustfrac,dustevol,ddustevol,& - idivv,icurlvx,icurlvy,icurlvz,idivB,icurlBx,icurlBy,icurlBz,deltav,ndustsmall + idivv,icurlvx,icurlvy,icurlvz,idivB,icurlBx,icurlBy,& + icurlBz,deltav,ndustsmall,apr_level use part, only:rad,radprop use unifdis, only:set_unifdis use physcon, only:pi,au,solarm @@ -344,7 +345,7 @@ subroutine test_derivs(ntests,npass,string) call set_linklist(npart,nactive,xyzh,vxyzu) call densityiterate(1,npart,nactive,xyzh,vxyzu,divcurlv,divcurlB,& Bevol,stressmax,fxyzu,fext,alphaind,gradh,& - rad,radprop,dvdx) + rad,radprop,dvdx,apr_level) if (id==master) call printused(tused) nfailed(:) = 0; m = 0 diff --git a/src/tests/test_gravity.f90 b/src/tests/test_gravity.f90 index db00c260a..47c0aaadf 100644 --- a/src/tests/test_gravity.f90 +++ b/src/tests/test_gravity.f90 @@ -32,6 +32,7 @@ module testgravity !----------------------------------------------------------------------- subroutine test_gravity(ntests,npass,string) use dim, only:gravity + use testapr, only:setup_apr_region_for_test integer, intent(inout) :: ntests,npass character(len=*), intent(in) :: string logical :: testdirectsum,testpolytrope,testtaylorseries,testall @@ -234,7 +235,7 @@ end subroutine test_taylorseries !----------------------------------------------------------------------- subroutine test_directsum(ntests,npass) use io, only:id,master - use dim, only:maxp,maxptmass,mpi + use dim, only:maxp,maxptmass,mpi,use_apr use part, only:init_part,npart,npartoftype,massoftype,xyzh,hfact,vxyzu,fxyzu, & gradh,poten,iphase,isetphase,maxphase,labeltype,& nptmass,xyzmh_ptmass,fxyz_ptmass,dsdt_ptmass,ibelong @@ -253,6 +254,7 @@ subroutine test_directsum(ntests,npass) use linklist, only:set_linklist use sort_particles, only:sort_part_id use mpibalance, only:balancedomains + use testapr, only:setup_apr_region_for_test integer, intent(inout) :: ntests,npass integer :: nfailed(18) @@ -307,6 +309,11 @@ subroutine test_directsum(ntests,npass) iphase(i) = isetphase(k,iactive=.true.) enddo endif +! +!--call apr setup if using it - this must be called after massoftype is set +! we're not using this right now, this test fails as is +! if (use_apr) call setup_apr_region_for_test() + ! !--set thermal terms and velocity to zero, so only force is gravity ! @@ -325,6 +332,8 @@ subroutine test_directsum(ntests,npass) !--call derivs to get everything initialised ! call get_derivs_global() + + ! !--reset force to zero ! diff --git a/src/tests/test_kdtree.F90 b/src/tests/test_kdtree.F90 index 4d5cfa0ab..ddb4730c2 100644 --- a/src/tests/test_kdtree.F90 +++ b/src/tests/test_kdtree.F90 @@ -72,7 +72,7 @@ subroutine test_kdtree(ntests,npass) ! call empty_tree(node) call cpu_time(t1) - call maketree(node,xyzh,npart,3,ifirstincell,ncells) + call maketree(node,xyzh,npart,3,ifirstincell,ncells,apr_tree=.false.) call cpu_time(t2) call print_time(t2-t1,'maketree completed in') ! diff --git a/src/tests/testsuite.F90 b/src/tests/testsuite.F90 index daa5e8f4f..60df03149 100644 --- a/src/tests/testsuite.F90 +++ b/src/tests/testsuite.F90 @@ -21,7 +21,7 @@ module test ! testindtstep, testiorig, testkdtree, testkernel, testlink, testmath, ! testmpi, testnimhd, testpart, testpoly, testptmass, testradiation, ! testrwdump, testsedov, testsetdisc, testsethier, testsmol, teststep, -! testwind, timing +! testwind, timing, testapr ! implicit none public :: testsuite @@ -31,7 +31,7 @@ module test contains subroutine testsuite(string,first,last,ntests,npass,nfail) - use io, only:iprint,id,master,iverbose + use io, only:iprint,id,master,iverbose,error use io_summary, only:summary_initialise use testderivs, only:test_derivs use teststep, only:test_step @@ -44,6 +44,7 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) use testsmol, only:test_smol use testpart, only:test_part use testnimhd, only:test_nonidealmhd + use testapr, only:test_apr #ifdef FINVSQRT use testmath, only:test_math #endif @@ -73,14 +74,15 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) #endif use timing, only:get_timings,print_time use mpiutils, only:barrier_mpi - use dim, only:do_radiation + use dim, only:do_radiation,use_apr character(len=*), intent(in) :: string logical, intent(in) :: first,last integer, intent(inout) :: ntests,npass,nfail logical :: testall,dolink,dokdtree,doderivs,dokernel,dostep,dorwdump,dosmol logical :: doptmass,dognewton,dosedov,doexternf,doindtstep,dogravity,dogeom logical :: dosetdisc,doeos,docooling,dodust,donimhd,docorotate,doany,dogrowth - logical :: dogr,doradiation,dopart,dopoly,dompi,dohier,dodamp,dowind,doiorig + logical :: dogr,doradiation,dopart,dopoly,dompi,dohier,dodamp,dowind,& + doiorig,doapr #ifdef FINVSQRT logical :: usefsqrt,usefinvsqrt #endif @@ -135,6 +137,7 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) dohier = .false. dodamp = .false. dowind = .false. + doapr = .false. doiorig = .false. if (index(string,'deriv') /= 0) doderivs = .true. @@ -159,10 +162,11 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) if (index(string,'wind') /= 0) dowind = .true. if (index(string,'iorig') /= 0) doiorig = .true. if (index(string,'ptmass') /= 0) doptmass = .true. + if (index(string,'apr') /= 0) doapr = .true. doany = any((/doderivs,dogravity,dodust,dogrowth,donimhd,dorwdump,& doptmass,docooling,dogeom,dogr,dosmol,doradiation,& - dopart,dopoly,dohier,dodamp,dowind,doiorig/)) + dopart,dopoly,dohier,dodamp,dowind,doiorig,doapr/)) select case(trim(string)) case('kernel','kern') @@ -207,6 +211,8 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) doiorig = .true. case('mpi') dompi = .true. + case('apr') + doapr = .true. case default if (.not.doany) testall = .true. end select @@ -215,9 +221,21 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) #ifdef FINVSQRT call test_math(ntests,npass,usefsqrt,usefinvsqrt) #endif + +! +!--apr test +! +if (use_apr.and.testall) then + write(*,*) '-DAPR not currently compatible with test suite, recompile with APR=no' + return +elseif (use_apr.and.doapr) then + call test_apr(ntests,npass) +endif + ! !--test kernel module ! + if (dokernel.or.testall) then call test_kernel(ntests,npass) endif @@ -411,6 +429,7 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) call test_wind(ntests,npass) call set_default_options_testsuite(iverbose) ! restore defaults endif + ! !--test of particle id ! diff --git a/src/utils/einsteintk_wrapper.f90 b/src/utils/einsteintk_wrapper.f90 index 28580cd41..96544a28f 100644 --- a/src/utils/einsteintk_wrapper.f90 +++ b/src/utils/einsteintk_wrapper.f90 @@ -136,7 +136,7 @@ end subroutine step_et2phantom_MoL subroutine et2phantom_tmunu() use part, only:npart,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& Bevol,rad,radprop,eos_vars,pxyzu,dens,metrics,tmunus,metricderivs,& - igas,rhoh,alphaind,dvdx,gradh + igas,rhoh,alphaind,dvdx,gradh,apr_level !use part, only:xyzh,vxyzu,fxyzu,pxyzu,dens,metricderivs, metrics, npart, tmunus,eos_vars use cons2prim, only: cons2primall use deriv @@ -161,7 +161,7 @@ subroutine et2phantom_tmunu() !call init_metric(npart,xyzh,metrics) ! Calculate the cons density call densityiterate(1,npart,npart,xyzh,vxyzu,divcurlv,divcurlB,Bevol,& - stressmax,fxyzu,fext,alphaind,gradh,rad,radprop,dvdx) + stressmax,fxyzu,fext,alphaind,gradh,rad,radprop,dvdx,apr_level) ! Get primative variables for tmunu call cons2primall(npart,xyzh,metrics,pxyzu,vxyzu,dens,eos_vars) @@ -183,7 +183,8 @@ end subroutine et2phantom_tmunu subroutine phantom2et_consvar() use part, only:npart,xyzh,vxyzu,fxyzu,fext,divcurlv,divcurlB,& - Bevol,rad,radprop,metrics,igas,rhoh,alphaind,dvdx,gradh + Bevol,rad,radprop,metrics,igas,rhoh,alphaind,dvdx,& + gradh,apr_level use densityforce, only:densityiterate use metric_tools, only:init_metric use linklist, only:set_linklist @@ -203,7 +204,7 @@ subroutine phantom2et_consvar() call init_metric(npart,xyzh,metrics) ! Calculate the cons density call densityiterate(1,npart,npart,xyzh,vxyzu,divcurlv,divcurlB,Bevol,& - stressmax,fxyzu,fext,alphaind,gradh,rad,radprop,dvdx) + stressmax,fxyzu,fext,alphaind,gradh,rad,radprop,dvdx,apr_level) ! Interpolate density to grid call phantom2et_rhostar diff --git a/src/utils/utils_disc.f90 b/src/utils/utils_disc.f90 index 91b783c29..bd38dd3a4 100644 --- a/src/utils/utils_disc.f90 +++ b/src/utils/utils_disc.f90 @@ -109,6 +109,8 @@ subroutine disc_analysis(xyzh,vxyz,npart,pmass,time,nbin,rmin,rmax,G,M_star,& write(*,'(a,/)') ' Height of the disc, H, will be calculated the slow way.' if (allocated(zsetgas)) deallocate(zsetgas) allocate(myz(npart)) + else + allocate(myz(0)) ! to prevent compiler warnings endif ! Move everything so that the centre of mass is at the origin @@ -228,8 +230,8 @@ subroutine disc_analysis(xyzh,vxyz,npart,pmass,time,nbin,rmin,rmax,G,M_star,& deallocate(zsetgas) ! clean up else call calculate_H_slow(nbin,npart,H,mybin,ninbin,myz) - deallocate(myz) ! clean up endif + deallocate(myz) ! clean up ! Print angular momentum of accreted particles angtot = sqrt(angx*angx + angy*angy + angz*angz) From 72b4783a249a82d949aa3ceb16f4a6909da967a8 Mon Sep 17 00:00:00 2001 From: Rebecca Nealon Date: Wed, 16 Oct 2024 11:13:31 +0100 Subject: [PATCH 052/134] [format-bot] obsolete .gt. .lt. .ge. .le. .eq. .ne. replaced --- src/main/kdtree.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/main/kdtree.F90 b/src/main/kdtree.F90 index 8c997cc30..2731bbd04 100644 --- a/src/main/kdtree.F90 +++ b/src/main/kdtree.F90 @@ -1043,8 +1043,8 @@ subroutine special_sort_particles_in_cell(iaxis,imin,imax,min_l,max_l,min_r,max_ if (slide_r) then do ii = 1,rem_nr ! next particle to shift across - k = minloc(dpivot,dim=1,mask=dpivot.gt.0.) + imin - 1 - if (k-imin+1==0) k = maxloc(dpivot,dim=1,mask=dpivot.lt.0.) + imin - 1 + k = minloc(dpivot,dim=1,mask=dpivot > 0.) + imin - 1 + if (k-imin+1==0) k = maxloc(dpivot,dim=1,mask=dpivot < 0.) + imin - 1 ! swap this with the first particle on the j side inodeparts_swap = inodeparts(k) @@ -1069,8 +1069,8 @@ subroutine special_sort_particles_in_cell(iaxis,imin,imax,min_l,max_l,min_r,max_ else do ii = 1,rem_nl ! next particle to shift across - k = maxloc(dpivot,dim=1,mask=dpivot.lt.0.) + imin - 1 - if (k-imin+1==0) k = minloc(dpivot,dim=1,mask=dpivot.gt.0.) + imin - 1 + k = maxloc(dpivot,dim=1,mask=dpivot < 0.) + imin - 1 + if (k-imin+1==0) k = minloc(dpivot,dim=1,mask=dpivot > 0.) + imin - 1 ! swap this with the last particle on the i side inodeparts_swap = inodeparts(k) From f0ddc143db82af5caf8f8d10f1f8fe634bcba4ee Mon Sep 17 00:00:00 2001 From: Rebecca Nealon Date: Wed, 16 Oct 2024 11:14:15 +0100 Subject: [PATCH 053/134] [header-bot] updated file headers --- src/main/apr.f90 | 35 ++++++++++++++++++-------------- src/main/apr_region.f90 | 28 +++++++++++-------------- src/main/cons2prim.f90 | 2 +- src/main/evolve.F90 | 2 +- src/main/initial.F90 | 21 ++++++++++--------- src/main/readwrite_infile.F90 | 2 +- src/main/relaxem.f90 | 25 ++++++++++++----------- src/main/subgroup.f90 | 3 +-- src/setup/relax_star.f90 | 9 ++++---- src/setup/setup_asteroidwind.f90 | 1 - src/setup/setup_star.f90 | 2 +- src/setup/setup_wave.f90 | 3 ++- src/tests/test_apr.f90 | 5 +++-- src/tests/test_gravity.f90 | 2 +- src/tests/test_ptmass.f90 | 10 ++++----- src/tests/testsuite.F90 | 14 ++++++------- 16 files changed, 84 insertions(+), 80 deletions(-) diff --git a/src/main/apr.f90 b/src/main/apr.f90 index 192940b0a..e12df89c6 100644 --- a/src/main/apr.f90 +++ b/src/main/apr.f90 @@ -1,24 +1,29 @@ !--------------------------------------------------------------------------! ! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! -! Copyright (c) 2007-2023 The Authors (see AUTHORS) ! +! Copyright (c) 2007-2024 The Authors (see AUTHORS) ! ! See LICENCE file for usage and distribution conditions ! ! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module apr - ! - ! Contains everything for live adaptive particle refinement - ! - ! :References: None - ! - ! :Owner: Rebecca Nealon - ! - ! :Runtime parameters: - ! - apr_max_in : number of refinement levels (3 -> 2x resolution) - ! - ref_dir : increase (1) or decrease (-1) resolution from the base resolution - ! - apr_type : choice of region, defined in apr_region.f90 - ! - ! :Dependencies: None - ! +! +! apr +! +! :References: None +! +! :Owner: Rebecca Nealon +! +! :Runtime parameters: +! - apr_drad : *size of step to next region* +! - apr_max : *number of additional refinement levels (3 -> 2x resolution)* +! - apr_rad : *radius of innermost region* +! - apr_type : *1: static, 2: moving sink, 3: create clumps* +! - ref_dir : *increase (1) or decrease (-1) resolution* +! - track_part : *number of sink to track* +! +! :Dependencies: apr_region, dim, infile_utils, io, kdtree, linklist, +! mpiforce, part, physcon, ptmass, quitdump, random, relaxem, +! timestep_ind, vectorutils +! implicit none public :: init_apr,update_apr,read_options_apr,write_options_apr diff --git a/src/main/apr_region.f90 b/src/main/apr_region.f90 index 9ae45ffeb..e0eb99806 100644 --- a/src/main/apr_region.f90 +++ b/src/main/apr_region.f90 @@ -1,25 +1,21 @@ !--------------------------------------------------------------------------! ! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! -! Copyright (c) 2007-2023 The Authors (see AUTHORS) ! +! Copyright (c) 2007-2024 The Authors (see AUTHORS) ! ! See LICENCE file for usage and distribution conditions ! ! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module apr_region - ! - ! Contains everything for setting the adaptive particle refinement regions - ! - ! :References: None - ! - ! :Owner: Rebecca Nealon - ! - ! :Runtime parameters: - ! - apr_max_in : number of refinement levels (3 -> 2x resolution) - ! - ref_dir : increase (1) or decrease (-1) resolution from the base resolution - ! - [x,y,z]_centre : centre coordinates of the region to be more highly resolved - ! - apr_rad : radius of the region to be more highly resolved - ! - ! :Dependencies: None - ! +! +! apr_region +! +! :References: None +! +! :Owner: Rebecca Nealon +! +! :Runtime parameters: None +! +! :Dependencies: part +! implicit none logical, public :: dynamic_apr = .false., apr_region_is_circle = .false. diff --git a/src/main/cons2prim.f90 b/src/main/cons2prim.f90 index e560b8f7b..729d22f9f 100644 --- a/src/main/cons2prim.f90 +++ b/src/main/cons2prim.f90 @@ -20,7 +20,7 @@ module cons2prim ! Liptai & Price (2019), MNRAS 485, 819-842 ! Ballabio et al. (2018), MNRAS 477, 2766-2771 ! -! :Owner: Daniel Price +! :Owner: Elisabeth Borchert ! ! :Runtime parameters: None ! diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 2c9be7286..16d45adc2 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -16,7 +16,7 @@ module evolve ! ! :Runtime parameters: None ! -! :Dependencies: HIIRegion, analysis, boundary_dyn, centreofmass, +! :Dependencies: HIIRegion, analysis, apr, boundary_dyn, centreofmass, ! checkconserved, dim, energies, evwrite, externalforces, fileutils, ! forcing, inject, io, io_summary, mf_write, mpiutils, options, part, ! partinject, ptmass, quitdump, radiation_utils, readwrite_dumps, diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 9843665fe..66cf176b4 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -14,16 +14,17 @@ module initial ! ! :Runtime parameters: None ! -! :Dependencies: HIIRegion, analysis, boundary, boundary_dyn, centreofmass, -! checkconserved, checkoptions, checksetup, cons2prim, cooling, cpuinfo, -! damping, densityforce, deriv, dim, dust, dust_formation, -! einsteintk_utils, energies, eos, evwrite, extern_gr, externalforces, -! fastmath, fileutils, forcing, growth, inject, io, io_summary, -! krome_interface, linklist, metric, metric_et_utils, metric_tools, -! mf_write, mpibalance, mpidomain, mpimemory, mpitree, mpiutils, nicil, -! nicil_sup, omputils, options, part, partinject, porosity, ptmass, -! radiation_utils, readwrite_dumps, readwrite_infile, subgroup, timestep, -! timestep_ind, timestep_sts, timing, tmunu2grid, units, writeheader +! :Dependencies: HIIRegion, analysis, apr, boundary, boundary_dyn, +! centreofmass, checkconserved, checkoptions, checksetup, cons2prim, +! cooling, cpuinfo, damping, densityforce, deriv, dim, dust, +! dust_formation, einsteintk_utils, energies, eos, evwrite, extern_gr, +! externalforces, fastmath, fileutils, forcing, growth, inject, io, +! io_summary, krome_interface, linklist, metric, metric_et_utils, +! metric_tools, mf_write, mpibalance, mpidomain, mpimemory, mpitree, +! mpiutils, nicil, nicil_sup, omputils, options, part, partinject, +! porosity, ptmass, radiation_utils, readwrite_dumps, readwrite_infile, +! subgroup, timestep, timestep_ind, timestep_sts, timing, tmunu2grid, +! units, writeheader ! implicit none diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index 520540d1f..e0d806c4c 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -65,7 +65,7 @@ module readwrite_infile ! - use_mcfost : *use the mcfost library* ! - xtol : *tolerance on xyz iterations* ! -! :Dependencies: HIIRegion, boundary_dyn, cooling, damping, dim, dust, +! :Dependencies: HIIRegion, apr, boundary_dyn, cooling, damping, dim, dust, ! dust_formation, eos, externalforces, forcing, gravwaveutils, growth, ! infile_utils, inject, io, linklist, metric, nicil_sup, options, part, ! porosity, ptmass, ptmass_radiation, radiation_implicit, diff --git a/src/main/relaxem.f90 b/src/main/relaxem.f90 index 38104151c..61b96b8d0 100644 --- a/src/main/relaxem.f90 +++ b/src/main/relaxem.f90 @@ -1,21 +1,22 @@ !--------------------------------------------------------------------------! ! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! -! Copyright (c) 2007-2023 The Authors (see AUTHORS) ! +! Copyright (c) 2007-2024 The Authors (see AUTHORS) ! ! See LICENCE file for usage and distribution conditions ! ! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! module relaxem - ! - ! Routine to shuffle particles towards a reference distribution - ! - ! :References: None - ! - ! :Owner: Rebecca Nealon - ! - ! :Runtime parameters: - ! - ! :Dependencies: timestep, part, kernel, bound, kdtree - ! +! +! relaxem +! +! :References: None +! +! :Owner: Rebecca Nealon +! +! :Runtime parameters: None +! +! :Dependencies: boundary, deriv, dim, eos, kernel, mpidomain, options, +! part +! implicit none contains diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index 16d7a7b26..6007a9694 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -18,8 +18,7 @@ module subgroup ! ! :Runtime parameters: None ! -! :Dependencies: io, mpiutils, part, physcon, timing, units, utils_kepler, -! utils_subgroup +! :Dependencies: io, mpiutils, part, timing, utils_kepler, utils_subgroup ! use utils_subgroup implicit none diff --git a/src/setup/relax_star.f90 b/src/setup/relax_star.f90 index cb502c4fc..df6c82d8f 100644 --- a/src/setup/relax_star.f90 +++ b/src/setup/relax_star.f90 @@ -17,10 +17,11 @@ module relaxstar ! - maxits : *maximum number of relaxation iterations* ! - tol_ekin : *tolerance on ekin/epot to stop relaxation* ! -! :Dependencies: checksetup, damping, deriv, dim, dump_utils, energies, -! eos, externalforces, fileutils, infile_utils, initial, io, io_summary, -! memory, options, part, physcon, ptmass, readwrite_dumps, setstar_utils, -! sortutils, step_lf_global, table_utils, units +! :Dependencies: apr, checksetup, damping, deriv, dim, dump_utils, +! energies, eos, externalforces, fileutils, infile_utils, initial, io, +! io_summary, linklist, memory, options, part, physcon, ptmass, +! readwrite_dumps, setstar_utils, sortutils, step_lf_global, table_utils, +! units ! implicit none public :: relax_star,write_options_relax,read_options_relax diff --git a/src/setup/setup_asteroidwind.f90 b/src/setup/setup_asteroidwind.f90 index 80cba105c..de849ec48 100644 --- a/src/setup/setup_asteroidwind.f90 +++ b/src/setup/setup_asteroidwind.f90 @@ -27,7 +27,6 @@ module setup ! - npart_at_end : *number of particles injected after norbits* ! - rinject : *radius of asteroid (km)* ! - semia : *semi-major axis (solar radii)* -! - mdot : *rate of mass to be injected (g/s)* ! ! :Dependencies: eos, extern_lensethirring, externalforces, infile_utils, ! inject, io, kernel, options, part, physcon, setbinary, spherical, diff --git a/src/setup/setup_star.f90 b/src/setup/setup_star.f90 index 1d5d7b039..58250ed2b 100644 --- a/src/setup/setup_star.f90 +++ b/src/setup/setup_star.f90 @@ -26,7 +26,7 @@ module setup ! - use_var_comp : *Use variable composition (X, Z, mu)* ! - write_rho_to_file : *write density profile(s) to file* ! -! :Dependencies: dim, eos, eos_gasradrec, eos_piecewise, +! :Dependencies: apr, dim, eos, eos_gasradrec, eos_piecewise, ! extern_densprofile, externalforces, infile_utils, io, kernel, ! mpidomain, mpiutils, options, part, physcon, prompting, relaxstar, ! setstar, setunits, setup_params, timestep, units diff --git a/src/setup/setup_wave.f90 b/src/setup/setup_wave.f90 index 7450aaee5..a124285f1 100644 --- a/src/setup/setup_wave.f90 +++ b/src/setup/setup_wave.f90 @@ -15,7 +15,8 @@ module setup ! :Runtime parameters: None ! ! :Dependencies: boundary, dim, dust, io, kernel, mpidomain, mpiutils, -! options, part, physcon, prompting, set_dust, setup_params, unifdis +! options, part, physcon, prompting, random, set_dust, setup_params, +! unifdis ! implicit none public :: setpart diff --git a/src/tests/test_apr.f90 b/src/tests/test_apr.f90 index 965d653a4..358757dd7 100644 --- a/src/tests/test_apr.f90 +++ b/src/tests/test_apr.f90 @@ -1,6 +1,6 @@ !--------------------------------------------------------------------------! ! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! -! Copyright (c) 2007-2023 The Authors (see AUTHORS) ! +! Copyright (c) 2007-2024 The Authors (see AUTHORS) ! ! See LICENCE file for usage and distribution conditions ! ! http://phantomsph.github.io/ ! !--------------------------------------------------------------------------! @@ -14,7 +14,8 @@ module testapr ! ! :Runtime parameters: None ! -! :Dependencies: apr, apr_region, linklist +! :Dependencies: apr, boundary, dim, io, linklist, mpidomain, mpiutils, +! part, physcon, testutils, unifdis, units ! use testutils, only:checkval,update_test_scores use io, only:id,master diff --git a/src/tests/test_gravity.f90 b/src/tests/test_gravity.f90 index 47c0aaadf..a7af2b2f1 100644 --- a/src/tests/test_gravity.f90 +++ b/src/tests/test_gravity.f90 @@ -16,7 +16,7 @@ module testgravity ! ! :Dependencies: deriv, dim, directsum, energies, eos, io, kdtree, ! linklist, mpibalance, mpiutils, options, part, physcon, ptmass, -! sort_particles, spherical, testutils, timing +! sort_particles, spherical, testapr, testutils, timing ! use io, only:id,master implicit none diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index eca5bd74b..ce6751ab8 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -14,11 +14,11 @@ module testptmass ! ! :Runtime parameters: None ! -! :Dependencies: HIIRegion, boundary, checksetup, deriv, dim, energies, -! eos, eos_HIIR, extern_binary, externalforces, gravwaveutils, io, -! kdtree, kernel, mpiutils, options, part, physcon, ptmass, random, -! setbinary, setdisc, spherical, step_lf_global, stretchmap, testutils, -! timestep, timing, units +! :Dependencies: HIIRegion, boundary, centreofmass, checksetup, deriv, dim, +! energies, eos, eos_HIIR, extern_binary, externalforces, gravwaveutils, +! io, kdtree, kernel, mpiutils, options, part, physcon, ptmass, random, +! setbinary, setdisc, spherical, step_lf_global, stretchmap, subgroup, +! testutils, timestep, timing, units ! use testutils, only:checkval,update_test_scores implicit none diff --git a/src/tests/testsuite.F90 b/src/tests/testsuite.F90 index 60df03149..bf638c33b 100644 --- a/src/tests/testsuite.F90 +++ b/src/tests/testsuite.F90 @@ -15,13 +15,13 @@ module test ! ! :Runtime parameters: None ! -! :Dependencies: dim, io, io_summary, mpiutils, options, testcooling, -! testcorotate, testdamping, testderivs, testdust, testeos, testexternf, -! testgeometry, testgnewton, testgr, testgravity, testgrowth, -! testindtstep, testiorig, testkdtree, testkernel, testlink, testmath, -! testmpi, testnimhd, testpart, testpoly, testptmass, testradiation, -! testrwdump, testsedov, testsetdisc, testsethier, testsmol, teststep, -! testwind, timing, testapr +! :Dependencies: dim, io, io_summary, mpiutils, options, testapr, +! testcooling, testcorotate, testdamping, testderivs, testdust, testeos, +! testexternf, testgeometry, testgnewton, testgr, testgravity, +! testgrowth, testindtstep, testiorig, testkdtree, testkernel, testlink, +! testmath, testmpi, testnimhd, testpart, testpoly, testptmass, +! testradiation, testrwdump, testsedov, testsetdisc, testsethier, +! testsmol, teststep, testwind, timing ! implicit none public :: testsuite From a4b138e1e5d185eadbdc3cbccc7d7b37007cd48e Mon Sep 17 00:00:00 2001 From: Rebecca Nealon Date: Wed, 16 Oct 2024 11:14:23 +0100 Subject: [PATCH 054/134] [space-bot] whitespace at end of lines removed --- src/main/kdtree.F90 | 2 +- src/main/substepping.F90 | 2 +- src/tests/test_gravity.f90 | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/main/kdtree.F90 b/src/main/kdtree.F90 index 2731bbd04..82847c674 100644 --- a/src/main/kdtree.F90 +++ b/src/main/kdtree.F90 @@ -919,7 +919,7 @@ subroutine sort_particles_in_cell(iaxis,imin,imax,min_l,max_l,min_r,max_r,nl,nr, if ( j /= i+1) print*,' ERROR ',i,j nl = max_l - min_l + 1 nr = max_r - min_r + 1 - + end subroutine sort_particles_in_cell !---------------------------------------------------------------- diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index b092b7b2d..f090fc187 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -1017,7 +1017,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, itype = iamtype(iphase(i)) if (use_apr) then pmassi = aprmassoftype(itype,apr_level(i)) - else + else pmassi = massoftype(itype) endif endif diff --git a/src/tests/test_gravity.f90 b/src/tests/test_gravity.f90 index a7af2b2f1..9fda4eb76 100644 --- a/src/tests/test_gravity.f90 +++ b/src/tests/test_gravity.f90 @@ -313,7 +313,7 @@ subroutine test_directsum(ntests,npass) !--call apr setup if using it - this must be called after massoftype is set ! we're not using this right now, this test fails as is ! if (use_apr) call setup_apr_region_for_test() - + ! !--set thermal terms and velocity to zero, so only force is gravity ! From 493ff94d9aa7200541d62d80f711e5ce2953da9e Mon Sep 17 00:00:00 2001 From: Rebecca Nealon Date: Wed, 16 Oct 2024 11:14:23 +0100 Subject: [PATCH 055/134] [author-bot] updated AUTHORS file --- AUTHORS | 1 + 1 file changed, 1 insertion(+) diff --git a/AUTHORS b/AUTHORS index b1dd08d0b..78279c152 100644 --- a/AUTHORS +++ b/AUTHORS @@ -57,6 +57,7 @@ Nicolás Cuello Chris Nixon Miguel Gonzalez-Bolivar Benoit Commercon +Christopher Russell Giulia Ballabio Joe Fisher Maxime Lombart From b5ceb03909e7d41c5380604e313730889aaaccd4 Mon Sep 17 00:00:00 2001 From: Rebecca Nealon Date: Wed, 16 Oct 2024 11:14:33 +0100 Subject: [PATCH 056/134] [format-bot] end if -> endif; end do -> enddo; if( -> if ( --- src/main/apr.f90 | 2 +- src/main/initial.F90 | 2 +- src/main/ptmass.F90 | 2 +- src/main/subgroup.f90 | 10 +++++----- src/main/substepping.F90 | 6 +++--- 5 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/main/apr.f90 b/src/main/apr.f90 index e12df89c6..31affdb4d 100644 --- a/src/main/apr.f90 +++ b/src/main/apr.f90 @@ -743,7 +743,7 @@ subroutine create_or_update_apr_clump(npart,xyzh,vxyzu,poten,apr_level,xyzmh_ptm if ((ibin == (minima(jj))) .or. & (ibin - 1 == (minima(jj))) .or. & (ibin + 1 == (minima(jj)))) then - if((poten(ii)/pmassi) < minpoten) then + if ((poten(ii)/pmassi) < minpoten) then minpoten = poten(ii)/pmassi min_particle(jj) = ii endif diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 66cf176b4..219ba620e 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -554,7 +554,7 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) else pmassi = massoftype(iamtype(iphase(i))) endif - else if (use_apr) then + elseif (use_apr) then pmassi = aprmassoftype(igas,apr_level(i)) endif if (use_regnbody) then diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index 7c3d6cb92..b0a148042 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -304,7 +304,7 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, ! timestep is sqrt(separation/force) fonrmax = max(f1,f2,fonrmax) if (kappa) then - if(abs(bin_info(isemi,j))>tiny(f2)) then + if (abs(bin_info(isemi,j))>tiny(f2)) then bin_info(ipert,j) = bin_info(ipert,j) + f2 endif endif diff --git a/src/main/subgroup.f90 b/src/main/subgroup.f90 index 6007a9694..beaa78c08 100644 --- a/src/main/subgroup.f90 +++ b/src/main/subgroup.f90 @@ -843,7 +843,7 @@ subroutine kick_TTL(h,W,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,fxyz_ptmass do k=s_id,e_id i = group_info(igarg,k) compi = group_info(icomp,k) - if(i/=compi) then + if (i/=compi) then kappai = bin_info(ikap,i) if (kappai >= 1.) then @@ -1087,7 +1087,7 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om, ddr = 1./sqrt(r2) mj = xyzmh_ptmass(4,j) if (j == compi) then - if(present(potonly) .and. present(energ)) then + if (present(potonly) .and. present(energ)) then gtk = mj*ddr else gtk = mj*ddr*kappa1i @@ -1125,7 +1125,7 @@ subroutine get_force_TTL(xyzmh_ptmass,group_info,bin_info,fxyz_ptmass,gtgrad,om, if (compi /=i) then semii = bin_info(isemi,i) mcomp = xyzmh_ptmass(4,compi) - if(semii >= 0) then + if (semii >= 0) then dsi = mi*mcomp*sqrt(semii/(mi+mcomp))*elli_res else dsi = mi*mcomp*sqrt(-semii/(mi+mcomp))*hyper_res @@ -1296,7 +1296,7 @@ subroutine get_force_TTL_bin(xyzmh_ptmass,fxyz_ptmass,gtgrad,om,kappa1,i,j,poton om = gtki*mi if (present(ds_init) .and. .not.present(potonly)) then - if(semiij >= 0) then + if (semiij >= 0) then ds_init = mi*mj*sqrt(semiij/(mi+mj))*elli_res else ds_init = mi*mj*sqrt(-semiij/(mi+mj))*hyper_res @@ -1383,7 +1383,7 @@ subroutine get_bin_com(i,j,xyzmh_ptmass,vxyz_ptmass,vcom,xcom) vcom(2) = (m1*vxyz_ptmass(2,i)+m2*vxyz_ptmass(2,j))/mtot vcom(3) = (m1*vxyz_ptmass(3,i)+m2*vxyz_ptmass(3,j))/mtot - if(present(xcom)) then + if (present(xcom)) then xcom(1) = (m1*xyzmh_ptmass(1,i)+m2*xyzmh_ptmass(1,j))/mtot xcom(2) = (m1*xyzmh_ptmass(2,i)+m2*xyzmh_ptmass(2,j))/mtot xcom(3) = (m1*xyzmh_ptmass(3,i)+m2*xyzmh_ptmass(3,j))/mtot diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index f090fc187..f16a842d6 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -205,7 +205,7 @@ subroutine substep_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,metric else pmassi = massoftype(itype) endif - else if (use_apr) then + elseif (use_apr) then pmassi = aprmassoftype(igas,apr_level(i)) endif @@ -332,7 +332,7 @@ subroutine substep_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,metric pmassi = massoftype(itype) endif ! if (itype==iboundary) cycle accreteloop - else if (use_apr) then + elseif (use_apr) then pmassi = aprmassoftype(igas,apr_level(i)) endif @@ -768,7 +768,7 @@ subroutine kick(dki,dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass, else pmassi = massoftype(itype) endif - else if (use_apr) then + elseif (use_apr) then pmassi = aprmassoftype(igas,apr_level(i)) endif ! From 3759ed3bff36ba30f20d11fe959127501964599e Mon Sep 17 00:00:00 2001 From: Rebecca Nealon Date: Wed, 16 Oct 2024 11:14:45 +0100 Subject: [PATCH 057/134] [indent-bot] standardised indentation --- src/main/apr.f90 | 1366 ++++++++++++++++++------------------- src/main/apr_region.f90 | 70 +- src/main/centreofmass.f90 | 64 +- src/main/dens.F90 | 24 +- src/main/force.F90 | 28 +- src/main/initial.F90 | 4 +- src/main/kdtree.F90 | 186 ++--- src/main/part.F90 | 8 +- src/main/relaxem.f90 | 218 +++--- src/setup/relax_star.f90 | 52 +- src/setup/setup_star.f90 | 12 +- src/tests/directsum.f90 | 6 +- src/tests/test_apr.f90 | 14 +- src/tests/testsuite.F90 | 12 +- src/utils/utils_disc.f90 | 2 +- 15 files changed, 1033 insertions(+), 1033 deletions(-) diff --git a/src/main/apr.f90 b/src/main/apr.f90 index 31affdb4d..0733027f8 100644 --- a/src/main/apr.f90 +++ b/src/main/apr.f90 @@ -24,740 +24,740 @@ module apr ! mpiforce, part, physcon, ptmass, quitdump, random, relaxem, ! timestep_ind, vectorutils ! - implicit none - - public :: init_apr,update_apr,read_options_apr,write_options_apr - public :: create_or_update_apr_clump - integer, public :: apr_max_in = 3, ref_dir = 1, apr_type = 1, apr_max - real, public :: apr_rad = 1.0, apr_drad = 0.1, apr_centre(3) - - private - integer :: top_level = 1, ntrack = 0, track_part = 0 - real, allocatable :: apr_regions(:) - integer, allocatable :: npart_regions(:) - real :: sep_factor = 0.2 - logical :: apr_verbose = .false. - logical :: do_relax = .false. - logical :: adjusted_split = .true. - logical :: directional = .true. + implicit none + + public :: init_apr,update_apr,read_options_apr,write_options_apr + public :: create_or_update_apr_clump + integer, public :: apr_max_in = 3, ref_dir = 1, apr_type = 1, apr_max + real, public :: apr_rad = 1.0, apr_drad = 0.1, apr_centre(3) + + private + integer :: top_level = 1, ntrack = 0, track_part = 0 + real, allocatable :: apr_regions(:) + integer, allocatable :: npart_regions(:) + real :: sep_factor = 0.2 + logical :: apr_verbose = .false. + logical :: do_relax = .false. + logical :: adjusted_split = .true. + logical :: directional = .true. contains - !----------------------------------------------------------------------- - !+ - ! Initialising all the apr arrays and properties - !+ - !----------------------------------------------------------------------- - subroutine init_apr(apr_level,ierr) - use dim, only:maxp_hard - use part, only:npart,massoftype,aprmassoftype - use apr_region, only:set_apr_centre,set_apr_regions - integer, intent(inout) :: ierr - integer(kind=1), intent(inout) :: apr_level(:) - logical :: previously_set - integer :: i - - ! the resolution levels are in addition to the base resolution - apr_max = apr_max_in + 1 - - ! if we're reading in a file that already has the levels set, - ! don't override these - previously_set = .false. - if (sum(int(apr_level(1:npart))) > npart) then - previously_set = .true. - do_relax = .false. - endif + !----------------------------------------------------------------------- + !+ + ! Initialising all the apr arrays and properties + !+ + !----------------------------------------------------------------------- +subroutine init_apr(apr_level,ierr) + use dim, only:maxp_hard + use part, only:npart,massoftype,aprmassoftype + use apr_region, only:set_apr_centre,set_apr_regions + integer, intent(inout) :: ierr + integer(kind=1), intent(inout) :: apr_level(:) + logical :: previously_set + integer :: i + + ! the resolution levels are in addition to the base resolution + apr_max = apr_max_in + 1 + + ! if we're reading in a file that already has the levels set, + ! don't override these + previously_set = .false. + if (sum(int(apr_level(1:npart))) > npart) then + previously_set = .true. + do_relax = .false. + endif - if (.not.previously_set) then - ! initialise the base resolution level - if (ref_dir == 1) then - apr_level(1:npart) = int(1,kind=1) - else - apr_level(1:npart) = int(apr_max,kind=1) - endif - endif - ! initiliase the regions - call set_apr_centre(apr_type,apr_centre,ntrack,track_part) - if (.not.allocated(apr_regions)) allocate(apr_regions(apr_max),npart_regions(apr_max)) - call set_apr_regions(ref_dir,apr_max,apr_regions,apr_rad,apr_drad) - npart_regions = 0 - - ! if we are derefining we make sure that - ! massoftype(igas) is associated with the - ! largest particle - if (ref_dir == -1) then - massoftype(:) = massoftype(:) * 2.**(apr_max -1) - top_level = 1 + if (.not.previously_set) then + ! initialise the base resolution level + if (ref_dir == 1) then + apr_level(1:npart) = int(1,kind=1) else - top_level = apr_max + apr_level(1:npart) = int(apr_max,kind=1) endif - - ! now set the aprmassoftype array, this stores all the masses for the different resolution levels - do i = 1,apr_max - aprmassoftype(:,i) = massoftype(:)/(2.**(i-1)) - enddo - - ierr = 0 - - if (apr_verbose) print*,'initialised apr' - - end subroutine init_apr - - !----------------------------------------------------------------------- - !+ - ! Subroutine to check if particles need to be split or merged - !+ - !----------------------------------------------------------------------- - subroutine update_apr(npart,xyzh,vxyzu,fxyzu,apr_level) - use dim, only:maxp_hard,ind_timesteps - use part, only:ntot,isdead_or_accreted,igas,aprmassoftype,& + endif + ! initiliase the regions + call set_apr_centre(apr_type,apr_centre,ntrack,track_part) + if (.not.allocated(apr_regions)) allocate(apr_regions(apr_max),npart_regions(apr_max)) + call set_apr_regions(ref_dir,apr_max,apr_regions,apr_rad,apr_drad) + npart_regions = 0 + + ! if we are derefining we make sure that + ! massoftype(igas) is associated with the + ! largest particle + if (ref_dir == -1) then + massoftype(:) = massoftype(:) * 2.**(apr_max -1) + top_level = 1 + else + top_level = apr_max + endif + + ! now set the aprmassoftype array, this stores all the masses for the different resolution levels + do i = 1,apr_max + aprmassoftype(:,i) = massoftype(:)/(2.**(i-1)) + enddo + + ierr = 0 + + if (apr_verbose) print*,'initialised apr' + +end subroutine init_apr + + !----------------------------------------------------------------------- + !+ + ! Subroutine to check if particles need to be split or merged + !+ + !----------------------------------------------------------------------- +subroutine update_apr(npart,xyzh,vxyzu,fxyzu,apr_level) + use dim, only:maxp_hard,ind_timesteps + use part, only:ntot,isdead_or_accreted,igas,aprmassoftype,& shuffle_part,iphase,iactive,poten,xyzmh_ptmass - use quitdump, only:quit - use relaxem, only:relax_particles - use apr_region, only:dynamic_apr,set_apr_centre - real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fxyzu(:,:) - integer, intent(inout) :: npart - integer(kind=1), intent(inout) :: apr_level(:) - integer :: ii,jj,kk,npartnew,nsplit_total,apri,npartold - integer :: n_ref,nrelax,nmerge,nkilled,apr_current - real, allocatable :: xyzh_ref(:,:),force_ref(:,:),pmass_ref(:) - real, allocatable :: xyzh_merge(:,:),vxyzu_merge(:,:) - integer, allocatable :: relaxlist(:),mergelist(:) - real :: xi,yi,zi,radi,radi_max - - ! if the centre of the region can move, update it - if (dynamic_apr) then - if (ntrack > 0) then - call create_or_update_apr_clump(npart,xyzh,vxyzu,poten,apr_level,& + use quitdump, only:quit + use relaxem, only:relax_particles + use apr_region, only:dynamic_apr,set_apr_centre + real, intent(inout) :: xyzh(:,:),vxyzu(:,:),fxyzu(:,:) + integer, intent(inout) :: npart + integer(kind=1), intent(inout) :: apr_level(:) + integer :: ii,jj,kk,npartnew,nsplit_total,apri,npartold + integer :: n_ref,nrelax,nmerge,nkilled,apr_current + real, allocatable :: xyzh_ref(:,:),force_ref(:,:),pmass_ref(:) + real, allocatable :: xyzh_merge(:,:),vxyzu_merge(:,:) + integer, allocatable :: relaxlist(:),mergelist(:) + real :: xi,yi,zi,radi,radi_max + + ! if the centre of the region can move, update it + if (dynamic_apr) then + if (ntrack > 0) then + call create_or_update_apr_clump(npart,xyzh,vxyzu,poten,apr_level,& xyzmh_ptmass,aprmassoftype) - else - call set_apr_centre(apr_type,apr_centre,ntrack,track_part) - endif + else + call set_apr_centre(apr_type,apr_centre,ntrack,track_part) endif + endif - ! If this routine doesn't need to be used, just skip it - if (apr_max == 1) return + ! If this routine doesn't need to be used, just skip it + if (apr_max == 1) return - ! Just a metric - if (apr_verbose) print*,'original npart is',npart + ! Just a metric + if (apr_verbose) print*,'original npart is',npart - ! Before adjusting the particles, if we're going to - ! relax them then let's save the reference particles - if (do_relax) then - allocate(xyzh_ref(4,maxp_hard),force_ref(3,maxp_hard),pmass_ref(maxp_hard),relaxlist(maxp_hard)) - relaxlist = -1 + ! Before adjusting the particles, if we're going to + ! relax them then let's save the reference particles + if (do_relax) then + allocate(xyzh_ref(4,maxp_hard),force_ref(3,maxp_hard),pmass_ref(maxp_hard),relaxlist(maxp_hard)) + relaxlist = -1 - n_ref = 0 - xyzh_ref = 0. - force_ref = 0. - pmass_ref = 0. + n_ref = 0 + xyzh_ref = 0. + force_ref = 0. + pmass_ref = 0. - do ii = 1,npart - if (.not.isdead_or_accreted(xyzh(4,ii))) then ! ignore dead particles + do ii = 1,npart + if (.not.isdead_or_accreted(xyzh(4,ii))) then ! ignore dead particles n_ref = n_ref + 1 xyzh_ref(1:4,n_ref) = xyzh(1:4,ii) pmass_ref(n_ref) = aprmassoftype(igas,apr_level(ii)) force_ref(1:3,n_ref) = fxyzu(1:3,ii)*pmass_ref(n_ref) - endif - enddo - endif + endif + enddo + endif - ! Do any particles need to be split? - npartnew = npart - npartold = npart - nsplit_total = 0 - nrelax = 0 - apri = 0 ! to avoid compiler errors + ! Do any particles need to be split? + npartnew = npart + npartold = npart + nsplit_total = 0 + nrelax = 0 + apri = 0 ! to avoid compiler errors - do jj = 1,apr_max-1 - npartold = npartnew ! to account for new particles as they are being made + do jj = 1,apr_max-1 + npartold = npartnew ! to account for new particles as they are being made - split_over_active: do ii = 1,npartold + split_over_active: do ii = 1,npartold - ! only do this on active particles - if (ind_timesteps) then + ! only do this on active particles + if (ind_timesteps) then if (.not.iactive(iphase(ii))) cycle split_over_active - endif - - apr_current = apr_level(ii) - xi = xyzh(1,ii) - yi = xyzh(2,ii) - zi = xyzh(3,ii) - ! this is the refinement level it *should* have based - ! on it's current position - call get_apr((/xi,yi,zi/),apri) - ! if the level it should have is greater than the - ! level it does have, increment it up one - if (apri > apr_current) then + endif + + apr_current = apr_level(ii) + xi = xyzh(1,ii) + yi = xyzh(2,ii) + zi = xyzh(3,ii) + ! this is the refinement level it *should* have based + ! on it's current position + call get_apr((/xi,yi,zi/),apri) + ! if the level it should have is greater than the + ! level it does have, increment it up one + if (apri > apr_current) then call splitpart(ii,npartnew) if (do_relax .and. (apri == top_level)) then - nrelax = nrelax + 2 - relaxlist(nrelax-1) = ii - relaxlist(nrelax) = npartnew + nrelax = nrelax + 2 + relaxlist(nrelax-1) = ii + relaxlist(nrelax) = npartnew endif nsplit_total = nsplit_total + 1 - endif - enddo split_over_active - enddo - - ! Take into account all the added particles - npart = npartnew - ntot = npartnew - if (apr_verbose) then - print*,'split: ',nsplit_total - print*,'npart: ',npart - endif - - ! Do any particles need to be merged? - allocate(mergelist(npart),xyzh_merge(4,npart),vxyzu_merge(4,npart)) - npart_regions = 0 - do jj = 1,apr_max-1 - kk = apr_max - jj + 1 ! to go from apr_max -> 2 - mergelist = -1 ! initialise - nmerge = 0 - nkilled = 0 - xyzh_merge = 0. - vxyzu_merge = 0. - radi_max = 0. - - merge_over_active: do ii = 1,npart - ! note that here we only do this process for particles that are not already counted in the blending region - if ((apr_level(ii) == kk) .and. (.not.isdead_or_accreted(xyzh(4,ii)))) then ! avoid already dead particles + endif + enddo split_over_active + enddo + + ! Take into account all the added particles + npart = npartnew + ntot = npartnew + if (apr_verbose) then + print*,'split: ',nsplit_total + print*,'npart: ',npart + endif + + ! Do any particles need to be merged? + allocate(mergelist(npart),xyzh_merge(4,npart),vxyzu_merge(4,npart)) + npart_regions = 0 + do jj = 1,apr_max-1 + kk = apr_max - jj + 1 ! to go from apr_max -> 2 + mergelist = -1 ! initialise + nmerge = 0 + nkilled = 0 + xyzh_merge = 0. + vxyzu_merge = 0. + radi_max = 0. + + merge_over_active: do ii = 1,npart + ! note that here we only do this process for particles that are not already counted in the blending region + if ((apr_level(ii) == kk) .and. (.not.isdead_or_accreted(xyzh(4,ii)))) then ! avoid already dead particles if (ind_timesteps) then - if (.not.iactive(iphase(ii))) cycle merge_over_active + if (.not.iactive(iphase(ii))) cycle merge_over_active endif nmerge = nmerge + 1 mergelist(nmerge) = ii xyzh_merge(1:4,nmerge) = xyzh(1:4,ii) vxyzu_merge(1:3,nmerge) = vxyzu(1:3,ii) npart_regions(kk) = npart_regions(kk) + 1 - endif - radi = sqrt(dot_product(xyzh(1:3,ii),xyzh(1:3,ii))) - if (radi > radi_max) radi_max = radi - enddo merge_over_active - ! Now send them to be merged - if (nmerge > 1) call merge_with_special_tree(nmerge,mergelist(1:nmerge),xyzh_merge(:,1:nmerge),& + endif + radi = sqrt(dot_product(xyzh(1:3,ii),xyzh(1:3,ii))) + if (radi > radi_max) radi_max = radi + enddo merge_over_active + ! Now send them to be merged + if (nmerge > 1) call merge_with_special_tree(nmerge,mergelist(1:nmerge),xyzh_merge(:,1:nmerge),& vxyzu_merge(:,1:nmerge),kk,xyzh,vxyzu,apr_level,nkilled,& nrelax,relaxlist,npartnew) - if (apr_verbose) then - print*,'merged: ',nkilled,kk - print*,'npart: ',npartnew - nkilled - endif - npart_regions(kk) = npart_regions(kk) - nkilled - enddo - ! update npart as required - npart = npartnew - npart_regions(1) = npartnew - sum(npart_regions(2:apr_max)) - if (apr_verbose) print*,'particles at each level:',npart_regions(:) - - ! If we need to relax, do it here - if (nrelax > 0 .and. do_relax) call relax_particles(npart,n_ref,xyzh_ref,force_ref,nrelax,relaxlist) - ! Turn it off now because we only want to do this on first splits - do_relax = .false. - - ! As we may have killed particles, time to do an array shuffle - call shuffle_part(npart) - - ! Tidy up - if (do_relax) then - deallocate(xyzh_ref,force_ref,pmass_ref,relaxlist) + if (apr_verbose) then + print*,'merged: ',nkilled,kk + print*,'npart: ',npartnew - nkilled endif - deallocate(mergelist) - - if (apr_verbose) print*,'total particles at end of apr: ',npart - - end subroutine update_apr - - !----------------------------------------------------------------------- - !+ - ! routine to return the adaptive particle refinement level based on position - ! and the boundaries set by the apr_* arrays - !+ - !----------------------------------------------------------------------- - subroutine get_apr(pos,apri) - use io, only:fatal - use apr_region, only:apr_region_is_circle - real, intent(in) :: pos(3) - integer, intent(out) :: apri - integer :: jj, kk - real :: dx,dy,dz,r - - apri = -1 ! to prevent compiler warnings - - do jj = 1,apr_max - if (ref_dir == 1) then - kk = apr_max - jj + 1 ! going from apr_max -> 1 - else - kk = jj ! going from 1 -> apr_max - endif - dx = pos(1) - apr_centre(1) - dy = pos(2) - apr_centre(2) - dz = pos(3) - apr_centre(3) - if (apr_region_is_circle) then - r = sqrt(dx**2 + dy**2) - else - r = sqrt(dx**2 + dy**2 + dz**2) - endif - if (r < apr_regions(kk)) then - apri = kk - return - endif - enddo - - if (apri == -1) call fatal('apr_region, get_apr','could not find apr level') - - end subroutine get_apr - - !----------------------------------------------------------------------- - !+ - ! routine to split one particle into two - !+ - !----------------------------------------------------------------------- - subroutine splitpart(i,npartnew) - use part, only:copy_particle_all,apr_level,xyzh,vxyzu,npartoftype,igas - use part, only:set_particle_type - use physcon, only:pi - use dim, only:ind_timesteps - use random, only:ran2 - use vectorutils, only:cross_product3D,rotatevec - use apr_region, only:apr_region_is_circle - integer, intent(in) :: i - integer, intent(inout) :: npartnew - integer :: j,npartold,next_door - real :: theta,dx,dy,dz,x_add,y_add,z_add,sep,rneigh - real :: v(3),u(3),w(3),a,b,c,mag_v - integer, save :: iseed = 4 - integer(kind=1) :: aprnew - - if (adjusted_split) then - call closest_neigh(i,next_door,rneigh) - sep = min(sep_factor*xyzh(4,i),0.35*rneigh) - sep = sep/xyzh(4,i) ! for consistency later on + npart_regions(kk) = npart_regions(kk) - nkilled + enddo + ! update npart as required + npart = npartnew + npart_regions(1) = npartnew - sum(npart_regions(2:apr_max)) + if (apr_verbose) print*,'particles at each level:',npart_regions(:) + + ! If we need to relax, do it here + if (nrelax > 0 .and. do_relax) call relax_particles(npart,n_ref,xyzh_ref,force_ref,nrelax,relaxlist) + ! Turn it off now because we only want to do this on first splits + do_relax = .false. + + ! As we may have killed particles, time to do an array shuffle + call shuffle_part(npart) + + ! Tidy up + if (do_relax) then + deallocate(xyzh_ref,force_ref,pmass_ref,relaxlist) + endif + deallocate(mergelist) + + if (apr_verbose) print*,'total particles at end of apr: ',npart + +end subroutine update_apr + + !----------------------------------------------------------------------- + !+ + ! routine to return the adaptive particle refinement level based on position + ! and the boundaries set by the apr_* arrays + !+ + !----------------------------------------------------------------------- +subroutine get_apr(pos,apri) + use io, only:fatal + use apr_region, only:apr_region_is_circle + real, intent(in) :: pos(3) + integer, intent(out) :: apri + integer :: jj, kk + real :: dx,dy,dz,r + + apri = -1 ! to prevent compiler warnings + + do jj = 1,apr_max + if (ref_dir == 1) then + kk = apr_max - jj + 1 ! going from apr_max -> 1 else - sep = sep_factor + kk = jj ! going from 1 -> apr_max endif - - ! Calculate the plane that the particle must be split along - ! to be tangential to the splitting region. Particles are split - ! on this plane but rotated randomly on it. - dx = xyzh(1,i) - apr_centre(1) - dy = xyzh(2,i) - apr_centre(2) - if (.not.apr_region_is_circle) then - dz = xyzh(3,i) - apr_centre(3) - - ! Calculate a vector, v, that lies on the plane - u = (/1.0,0.5,1.0/) - w = (/dx,dy,dz/) - call cross_product3D(u,w,v) - - ! rotate it around the normal to the plane by a random amount - theta = ran2(iseed)*2.*pi - call rotatevec(v,w,theta) - - if (.not.directional) then - ! No directional splitting, so just create a unit vector in a random direction - a = ran2(iseed) - 0.5 - b = ran2(iseed) - 0.5 - c = ran2(iseed) - 0.5 - v = (/a, b, c/) - endif - - mag_v = sqrt(dot_product(v,v)) - if (mag_v > tiny(mag_v)) then - v = v/mag_v - else - v = 0. - endif + dx = pos(1) - apr_centre(1) + dy = pos(2) - apr_centre(2) + dz = pos(3) - apr_centre(3) + if (apr_region_is_circle) then + r = sqrt(dx**2 + dy**2) else - dz = 0. - u = 0. - w = 0. - v = 0. - theta = atan2(dy,dx) + 0.5*pi - v(1) = cos(theta) - v(2) = sin(theta) + r = sqrt(dx**2 + dy**2 + dz**2) + endif + if (r < apr_regions(kk)) then + apri = kk + return + endif + enddo + + if (apri == -1) call fatal('apr_region, get_apr','could not find apr level') + +end subroutine get_apr + + !----------------------------------------------------------------------- + !+ + ! routine to split one particle into two + !+ + !----------------------------------------------------------------------- +subroutine splitpart(i,npartnew) + use part, only:copy_particle_all,apr_level,xyzh,vxyzu,npartoftype,igas + use part, only:set_particle_type + use physcon, only:pi + use dim, only:ind_timesteps + use random, only:ran2 + use vectorutils, only:cross_product3D,rotatevec + use apr_region, only:apr_region_is_circle + integer, intent(in) :: i + integer, intent(inout) :: npartnew + integer :: j,npartold,next_door + real :: theta,dx,dy,dz,x_add,y_add,z_add,sep,rneigh + real :: v(3),u(3),w(3),a,b,c,mag_v + integer, save :: iseed = 4 + integer(kind=1) :: aprnew + + if (adjusted_split) then + call closest_neigh(i,next_door,rneigh) + sep = min(sep_factor*xyzh(4,i),0.35*rneigh) + sep = sep/xyzh(4,i) ! for consistency later on + else + sep = sep_factor + endif + + ! Calculate the plane that the particle must be split along + ! to be tangential to the splitting region. Particles are split + ! on this plane but rotated randomly on it. + dx = xyzh(1,i) - apr_centre(1) + dy = xyzh(2,i) - apr_centre(2) + if (.not.apr_region_is_circle) then + dz = xyzh(3,i) - apr_centre(3) + + ! Calculate a vector, v, that lies on the plane + u = (/1.0,0.5,1.0/) + w = (/dx,dy,dz/) + call cross_product3D(u,w,v) + + ! rotate it around the normal to the plane by a random amount + theta = ran2(iseed)*2.*pi + call rotatevec(v,w,theta) + + if (.not.directional) then + ! No directional splitting, so just create a unit vector in a random direction + a = ran2(iseed) - 0.5 + b = ran2(iseed) - 0.5 + c = ran2(iseed) - 0.5 + v = (/a, b, c/) endif - ! Now apply it - x_add = sep*v(1)*xyzh(4,i) - y_add = sep*v(2)*xyzh(4,i) - z_add = sep*v(3)*xyzh(4,i) - - npartold = npartnew - npartnew = npartold + 1 - npartoftype(igas) = npartoftype(igas) + 1 - aprnew = apr_level(i) + int(1,kind=1) ! to prevent compiler warnings - - !--create the new particle - do j=npartold+1,npartnew - call copy_particle_all(i,j,new_part=.true.) - xyzh(1,j) = xyzh(1,i) + x_add - xyzh(2,j) = xyzh(2,i) + y_add - xyzh(3,j) = xyzh(3,i) + z_add - vxyzu(:,j) = vxyzu(:,i) - xyzh(4,j) = xyzh(4,i)*(0.5**(1./3.)) - apr_level(j) = aprnew - if (ind_timesteps) call put_in_smallest_bin(j) - enddo - - ! Edit the old particle that was sent in and kept - xyzh(1,i) = xyzh(1,i) - x_add - xyzh(2,i) = xyzh(2,i) - y_add - xyzh(3,i) = xyzh(3,i) - z_add - apr_level(i) = aprnew - xyzh(4,i) = xyzh(4,i)*(0.5**(1./3.)) - if (ind_timesteps) call put_in_smallest_bin(i) - - end subroutine splitpart - - !----------------------------------------------------------------------- - !+ - ! Take in all particles that *might* be merged at this apr_level - ! and use our special tree to merge what has left the region - !+ - !----------------------------------------------------------------------- - subroutine merge_with_special_tree(nmerge,mergelist,xyzh_merge,vxyzu_merge,current_apr,& + mag_v = sqrt(dot_product(v,v)) + if (mag_v > tiny(mag_v)) then + v = v/mag_v + else + v = 0. + endif + else + dz = 0. + u = 0. + w = 0. + v = 0. + theta = atan2(dy,dx) + 0.5*pi + v(1) = cos(theta) + v(2) = sin(theta) + endif + + ! Now apply it + x_add = sep*v(1)*xyzh(4,i) + y_add = sep*v(2)*xyzh(4,i) + z_add = sep*v(3)*xyzh(4,i) + + npartold = npartnew + npartnew = npartold + 1 + npartoftype(igas) = npartoftype(igas) + 1 + aprnew = apr_level(i) + int(1,kind=1) ! to prevent compiler warnings + + !--create the new particle + do j=npartold+1,npartnew + call copy_particle_all(i,j,new_part=.true.) + xyzh(1,j) = xyzh(1,i) + x_add + xyzh(2,j) = xyzh(2,i) + y_add + xyzh(3,j) = xyzh(3,i) + z_add + vxyzu(:,j) = vxyzu(:,i) + xyzh(4,j) = xyzh(4,i)*(0.5**(1./3.)) + apr_level(j) = aprnew + if (ind_timesteps) call put_in_smallest_bin(j) + enddo + + ! Edit the old particle that was sent in and kept + xyzh(1,i) = xyzh(1,i) - x_add + xyzh(2,i) = xyzh(2,i) - y_add + xyzh(3,i) = xyzh(3,i) - z_add + apr_level(i) = aprnew + xyzh(4,i) = xyzh(4,i)*(0.5**(1./3.)) + if (ind_timesteps) call put_in_smallest_bin(i) + +end subroutine splitpart + + !----------------------------------------------------------------------- + !+ + ! Take in all particles that *might* be merged at this apr_level + ! and use our special tree to merge what has left the region + !+ + !----------------------------------------------------------------------- +subroutine merge_with_special_tree(nmerge,mergelist,xyzh_merge,vxyzu_merge,current_apr,& xyzh,vxyzu,apr_level,nkilled,nrelax,relaxlist,npartnew) - use linklist, only:set_linklist,ncells,ifirstincell,get_cell_location - use mpiforce, only:cellforce - use kdtree, only:inodeparts,inoderange - use part, only:kill_particle,npartoftype - use dim, only:ind_timesteps - integer, intent(inout) :: nmerge,nkilled,nrelax,relaxlist(:),npartnew - integer(kind=1), intent(inout) :: apr_level(:) - integer, intent(in) :: current_apr,mergelist(:) - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - real, intent(inout) :: xyzh_merge(:,:),vxyzu_merge(:,:) - integer :: remainder,icell,i,n_cell,apri,m - integer :: eldest,tuther - real :: com(3) - type(cellforce) :: cell - - ! First ensure that we're only sending in a multiple of 2 to the tree - remainder = modulo(nmerge,2) - nmerge = nmerge - remainder - - call set_linklist(nmerge,nmerge,xyzh_merge(:,1:nmerge),vxyzu_merge(:,1:nmerge),& + use linklist, only:set_linklist,ncells,ifirstincell,get_cell_location + use mpiforce, only:cellforce + use kdtree, only:inodeparts,inoderange + use part, only:kill_particle,npartoftype + use dim, only:ind_timesteps + integer, intent(inout) :: nmerge,nkilled,nrelax,relaxlist(:),npartnew + integer(kind=1), intent(inout) :: apr_level(:) + integer, intent(in) :: current_apr,mergelist(:) + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + real, intent(inout) :: xyzh_merge(:,:),vxyzu_merge(:,:) + integer :: remainder,icell,i,n_cell,apri,m + integer :: eldest,tuther + real :: com(3) + type(cellforce) :: cell + + ! First ensure that we're only sending in a multiple of 2 to the tree + remainder = modulo(nmerge,2) + nmerge = nmerge - remainder + + call set_linklist(nmerge,nmerge,xyzh_merge(:,1:nmerge),vxyzu_merge(:,1:nmerge),& for_apr=.true.) - ! Now use the centre of mass of each cell to check whether it should - ! be merged or not - com = 0. - over_cells: do icell=1,int(ncells) - i = ifirstincell(icell) - if (i == 0) cycle over_cells !--skip empty cells - n_cell = inoderange(2,icell)-inoderange(1,icell)+1 - - call get_cell_location(icell,cell%xpos,cell%xsizei,cell%rcuti) - com(1) = cell%xpos(1) - com(2) = cell%xpos(2) - com(3) = cell%xpos(3) - call get_apr(com(1:3),apri) - - ! If the apr level based on the com is lower than the current level, - ! we merge! - if (apri < current_apr) then - eldest = mergelist(inodeparts(inoderange(1,icell))) - tuther = mergelist(inodeparts(inoderange(1,icell) + 1)) !as in kdtree - - ! keep eldest, reassign it to have the com properties - xyzh(1,eldest) = cell%xpos(1) - xyzh(2,eldest) = cell%xpos(2) - xyzh(3,eldest) = cell%xpos(3) - vxyzu(1:3,eldest) = 0.5*(vxyzu(1:3,eldest) + vxyzu(1:3,tuther)) - - xyzh(4,eldest) = (0.5*(xyzh(4,eldest) + xyzh(4,tuther)))*(2.0**(1./3.)) - apr_level(eldest) = apr_level(eldest) - int(1,kind=1) - if (ind_timesteps) call put_in_smallest_bin(eldest) - - ! add it to the shuffling list if needed - if (do_relax) then + ! Now use the centre of mass of each cell to check whether it should + ! be merged or not + com = 0. + over_cells: do icell=1,int(ncells) + i = ifirstincell(icell) + if (i == 0) cycle over_cells !--skip empty cells + n_cell = inoderange(2,icell)-inoderange(1,icell)+1 + + call get_cell_location(icell,cell%xpos,cell%xsizei,cell%rcuti) + com(1) = cell%xpos(1) + com(2) = cell%xpos(2) + com(3) = cell%xpos(3) + call get_apr(com(1:3),apri) + + ! If the apr level based on the com is lower than the current level, + ! we merge! + if (apri < current_apr) then + eldest = mergelist(inodeparts(inoderange(1,icell))) + tuther = mergelist(inodeparts(inoderange(1,icell) + 1)) !as in kdtree + + ! keep eldest, reassign it to have the com properties + xyzh(1,eldest) = cell%xpos(1) + xyzh(2,eldest) = cell%xpos(2) + xyzh(3,eldest) = cell%xpos(3) + vxyzu(1:3,eldest) = 0.5*(vxyzu(1:3,eldest) + vxyzu(1:3,tuther)) + + xyzh(4,eldest) = (0.5*(xyzh(4,eldest) + xyzh(4,tuther)))*(2.0**(1./3.)) + apr_level(eldest) = apr_level(eldest) - int(1,kind=1) + if (ind_timesteps) call put_in_smallest_bin(eldest) + + ! add it to the shuffling list if needed + if (do_relax) then nrelax = nrelax + 1 relaxlist(nrelax) = eldest - endif + endif - ! discard tuther (t'other) - call kill_particle(tuther,npartoftype) - nkilled = nkilled + 2 ! this refers to the number of children killed - ! If this particle was on the shuffle list previously, take it off - do m = 1,nrelax + ! discard tuther (t'other) + call kill_particle(tuther,npartoftype) + nkilled = nkilled + 2 ! this refers to the number of children killed + ! If this particle was on the shuffle list previously, take it off + do m = 1,nrelax if (relaxlist(m) == tuther) relaxlist(m) = 0 - enddo - endif - - enddo over_cells - - end subroutine merge_with_special_tree - - !----------------------------------------------------------------------- - !+ - ! reads input options from the input file - !+ - !----------------------------------------------------------------------- - subroutine read_options_apr(name,valstring,imatch,igotall,ierr) - use io, only:fatal - character(len=*), intent(in) :: name,valstring - logical, intent(out) :: imatch,igotall - integer, intent(out) :: ierr - integer, save :: ngot = 0 - character(len=30), parameter :: label = 'read_options_apr' - - imatch = .true. - select case(trim(name)) - case('apr_max') - read(valstring,*,iostat=ierr) apr_max_in - ngot = ngot + 1 - if (apr_max_in < 0) call fatal(label,'apr_max < 0 in input options') - case('ref_dir') - read(valstring,*,iostat=ierr) ref_dir - ngot = ngot + 1 - case('apr_type') - read(valstring,*,iostat=ierr) apr_type - ngot = ngot + 1 - case('apr_rad') - read(valstring,*,iostat=ierr) apr_rad - ngot = ngot + 1 - if (apr_rad < tiny(apr_rad)) call fatal(label,'apr_rad too small in input options') - case('apr_drad') - read(valstring,*,iostat=ierr) apr_drad - ngot = ngot + 1 - if (apr_drad < tiny(apr_drad)) call fatal(label,'apr_drad too small in input options') - case default - imatch = .false. - select case(apr_type) - case(1) - call read_options_apr1(name,valstring,imatch,igotall,ierr) - case(2) - call read_options_apr2(name,valstring,imatch,igotall,ierr) - end select - end select - - igotall = (ngot == 5) - end subroutine read_options_apr - - !----------------------------------------------------------------------- - !+ - ! extra subroutines for reading in different styles of apr zones - !+ - !----------------------------------------------------------------------- - - subroutine read_options_apr1(name,valstring,imatch,igotall,ierr) - use io, only:fatal - character(len=*), intent(in) :: name,valstring - logical, intent(out) :: imatch,igotall - integer, intent(out) :: ierr - integer, save :: ngot = 0 - character(len=30), parameter :: label = 'read_options_apr1' - - imatch = .true. - select case(trim(name)) - case('apr_centre(1)') - read(valstring,*,iostat=ierr) apr_centre(1) - ngot = ngot + 1 - case('apr_centre(2)') - read(valstring,*,iostat=ierr) apr_centre(2) - ngot = ngot + 1 - case('apr_centre(3)') - read(valstring,*,iostat=ierr) apr_centre(3) - ngot = ngot + 1 - case default - imatch = .false. - end select - - end subroutine read_options_apr1 - - subroutine read_options_apr2(name,valstring,imatch,igotall,ierr) - use io, only:fatal - character(len=*), intent(in) :: name,valstring - logical, intent(out) :: imatch,igotall - integer, intent(out) :: ierr - integer, save :: ngot = 0 - character(len=30), parameter :: label = 'read_options_apr2' - - imatch = .true. - select case(trim(name)) - case('track_part') - read(valstring,*,iostat=ierr) track_part - ngot = ngot + 1 - if (track_part < 1) call fatal(label,'track_part not chosen in input options') - case default - imatch = .false. - end select - - end subroutine read_options_apr2 - - !----------------------------------------------------------------------- - !+ - ! Writes input options to the input file. - !+ - !----------------------------------------------------------------------- - subroutine write_options_apr(iunit) - use infile_utils, only:write_inopt - integer, intent(in) :: iunit - - call write_inopt(apr_max_in,'apr_max','number of additional refinement levels (3 -> 2x resolution)',iunit) - call write_inopt(ref_dir,'ref_dir','increase (1) or decrease (-1) resolution',iunit) - call write_inopt(apr_type,'apr_type','1: static, 2: moving sink, 3: create clumps',iunit) - select case (apr_type) + enddo + endif + enddo over_cells + +end subroutine merge_with_special_tree + + !----------------------------------------------------------------------- + !+ + ! reads input options from the input file + !+ + !----------------------------------------------------------------------- +subroutine read_options_apr(name,valstring,imatch,igotall,ierr) + use io, only:fatal + character(len=*), intent(in) :: name,valstring + logical, intent(out) :: imatch,igotall + integer, intent(out) :: ierr + integer, save :: ngot = 0 + character(len=30), parameter :: label = 'read_options_apr' + + imatch = .true. + select case(trim(name)) + case('apr_max') + read(valstring,*,iostat=ierr) apr_max_in + ngot = ngot + 1 + if (apr_max_in < 0) call fatal(label,'apr_max < 0 in input options') + case('ref_dir') + read(valstring,*,iostat=ierr) ref_dir + ngot = ngot + 1 + case('apr_type') + read(valstring,*,iostat=ierr) apr_type + ngot = ngot + 1 + case('apr_rad') + read(valstring,*,iostat=ierr) apr_rad + ngot = ngot + 1 + if (apr_rad < tiny(apr_rad)) call fatal(label,'apr_rad too small in input options') + case('apr_drad') + read(valstring,*,iostat=ierr) apr_drad + ngot = ngot + 1 + if (apr_drad < tiny(apr_drad)) call fatal(label,'apr_drad too small in input options') + case default + imatch = .false. + select case(apr_type) + case(1) + call read_options_apr1(name,valstring,imatch,igotall,ierr) case(2) - call write_inopt(track_part,'track_part','number of sink to track',iunit) - - case default - call write_inopt(apr_centre(1),'apr_centre(1)','centre of region x position',iunit) - call write_inopt(apr_centre(2),'apr_centre(2)','centre of region y position',iunit) - call write_inopt(apr_centre(3),'apr_centre(3)','centre of region z position',iunit) - + call read_options_apr2(name,valstring,imatch,igotall,ierr) end select - call write_inopt(apr_rad,'apr_rad','radius of innermost region',iunit) - call write_inopt(apr_drad,'apr_drad','size of step to next region',iunit) - - end subroutine write_options_apr - - subroutine closest_neigh(i,next_door,rmin) - use part, only:xyzh,npart - integer, intent(in) :: i - integer, intent(out) :: next_door - real, intent(out) :: rmin - real :: dx,dy,dz,rtest - integer :: j - - rmin = huge(rmin) - next_door = 0 - do j = 1,npart - if (j == i) cycle - dx = xyzh(1,i) - xyzh(1,j) - dy = xyzh(2,i) - xyzh(2,j) - dz = xyzh(3,i) - xyzh(3,j) - rtest = dx**2 + dy**2 + dz**2 - if (rtest < rmin) then - next_door = j - rmin = rtest - endif - enddo - - rmin = sqrt(rmin) - - end subroutine closest_neigh - - !----------------------------------------------------------------------- - !+ - ! routine to put a particle on the shortest timestep - !+ - !----------------------------------------------------------------------- - subroutine put_in_smallest_bin(i) - use timestep_ind, only:nbinmax - use part, only:ibin - integer, intent(in) :: i - - ibin(i) = nbinmax - - end subroutine put_in_smallest_bin - - !----------------------------------------------------------------------- - !+ - ! Create a new apr region that is centred on a dense clump - ! (This is work in progress) - !+ - !----------------------------------------------------------------------- - - subroutine create_or_update_apr_clump(npart,xyzh,vxyzu,poten,apr_level,xyzmh_ptmass,aprmassoftype) - use apr_region, only:set_apr_centre - use part, only:igas,rhoh - use ptmass, only:rho_crit_cgs - integer, intent(in) :: npart - integer(kind=1), intent(in) :: apr_level(:) - real, intent(in) :: xyzh(:,:), vxyzu(:,:), aprmassoftype(:,:),xyzmh_ptmass(:,:) - real(kind=4), intent(in) :: poten(:) - integer :: nbins, ii, ibin, nmins, jj, apri - integer, allocatable :: counter(:), minima(:), min_particle(:) - real, allocatable :: radius(:), ave_poten(:) - real :: rin, rout, dbin, dx, dy, dz, rad, gradleft, gradright - real :: minpoten, pmassi, rhoi - - ! set up arrays - nbins = 100 - allocate(counter(nbins),radius(nbins),ave_poten(nbins),& + end select + + igotall = (ngot == 5) +end subroutine read_options_apr + + !----------------------------------------------------------------------- + !+ + ! extra subroutines for reading in different styles of apr zones + !+ + !----------------------------------------------------------------------- + +subroutine read_options_apr1(name,valstring,imatch,igotall,ierr) + use io, only:fatal + character(len=*), intent(in) :: name,valstring + logical, intent(out) :: imatch,igotall + integer, intent(out) :: ierr + integer, save :: ngot = 0 + character(len=30), parameter :: label = 'read_options_apr1' + + imatch = .true. + select case(trim(name)) + case('apr_centre(1)') + read(valstring,*,iostat=ierr) apr_centre(1) + ngot = ngot + 1 + case('apr_centre(2)') + read(valstring,*,iostat=ierr) apr_centre(2) + ngot = ngot + 1 + case('apr_centre(3)') + read(valstring,*,iostat=ierr) apr_centre(3) + ngot = ngot + 1 + case default + imatch = .false. + end select + +end subroutine read_options_apr1 + +subroutine read_options_apr2(name,valstring,imatch,igotall,ierr) + use io, only:fatal + character(len=*), intent(in) :: name,valstring + logical, intent(out) :: imatch,igotall + integer, intent(out) :: ierr + integer, save :: ngot = 0 + character(len=30), parameter :: label = 'read_options_apr2' + + imatch = .true. + select case(trim(name)) + case('track_part') + read(valstring,*,iostat=ierr) track_part + ngot = ngot + 1 + if (track_part < 1) call fatal(label,'track_part not chosen in input options') + case default + imatch = .false. + end select + +end subroutine read_options_apr2 + + !----------------------------------------------------------------------- + !+ + ! Writes input options to the input file. + !+ + !----------------------------------------------------------------------- +subroutine write_options_apr(iunit) + use infile_utils, only:write_inopt + integer, intent(in) :: iunit + + call write_inopt(apr_max_in,'apr_max','number of additional refinement levels (3 -> 2x resolution)',iunit) + call write_inopt(ref_dir,'ref_dir','increase (1) or decrease (-1) resolution',iunit) + call write_inopt(apr_type,'apr_type','1: static, 2: moving sink, 3: create clumps',iunit) + select case (apr_type) + + case(2) + call write_inopt(track_part,'track_part','number of sink to track',iunit) + + case default + call write_inopt(apr_centre(1),'apr_centre(1)','centre of region x position',iunit) + call write_inopt(apr_centre(2),'apr_centre(2)','centre of region y position',iunit) + call write_inopt(apr_centre(3),'apr_centre(3)','centre of region z position',iunit) + + end select + call write_inopt(apr_rad,'apr_rad','radius of innermost region',iunit) + call write_inopt(apr_drad,'apr_drad','size of step to next region',iunit) + +end subroutine write_options_apr + +subroutine closest_neigh(i,next_door,rmin) + use part, only:xyzh,npart + integer, intent(in) :: i + integer, intent(out) :: next_door + real, intent(out) :: rmin + real :: dx,dy,dz,rtest + integer :: j + + rmin = huge(rmin) + next_door = 0 + do j = 1,npart + if (j == i) cycle + dx = xyzh(1,i) - xyzh(1,j) + dy = xyzh(2,i) - xyzh(2,j) + dz = xyzh(3,i) - xyzh(3,j) + rtest = dx**2 + dy**2 + dz**2 + if (rtest < rmin) then + next_door = j + rmin = rtest + endif + enddo + + rmin = sqrt(rmin) + +end subroutine closest_neigh + + !----------------------------------------------------------------------- + !+ + ! routine to put a particle on the shortest timestep + !+ + !----------------------------------------------------------------------- +subroutine put_in_smallest_bin(i) + use timestep_ind, only:nbinmax + use part, only:ibin + integer, intent(in) :: i + + ibin(i) = nbinmax + +end subroutine put_in_smallest_bin + + !----------------------------------------------------------------------- + !+ + ! Create a new apr region that is centred on a dense clump + ! (This is work in progress) + !+ + !----------------------------------------------------------------------- + +subroutine create_or_update_apr_clump(npart,xyzh,vxyzu,poten,apr_level,xyzmh_ptmass,aprmassoftype) + use apr_region, only:set_apr_centre + use part, only:igas,rhoh + use ptmass, only:rho_crit_cgs + integer, intent(in) :: npart + integer(kind=1), intent(in) :: apr_level(:) + real, intent(in) :: xyzh(:,:), vxyzu(:,:), aprmassoftype(:,:),xyzmh_ptmass(:,:) + real(kind=4), intent(in) :: poten(:) + integer :: nbins, ii, ibin, nmins, jj, apri + integer, allocatable :: counter(:), minima(:), min_particle(:) + real, allocatable :: radius(:), ave_poten(:) + real :: rin, rout, dbin, dx, dy, dz, rad, gradleft, gradright + real :: minpoten, pmassi, rhoi + + ! set up arrays + nbins = 100 + allocate(counter(nbins),radius(nbins),ave_poten(nbins),& minima(nbins),min_particle(nbins)) - ! Currently hardwired but this is problematic - rin = 10. - rout = 100. - dbin = (rout-rin)/real(nbins-1) - do ii = 1,nbins - radius(ii) = rin + real(ii-1)*dbin - enddo - - ave_poten = 0. - counter = 0 - ! Create an azimuthally averaged potential energy vs. radius profile - do ii = 1,npart - dx = xyzh(1,ii) - xyzmh_ptmass(1,1) - dy = xyzh(2,ii) - xyzmh_ptmass(2,1) - dz = xyzh(3,ii) - xyzmh_ptmass(3,1) - rad = sqrt(dx**2 + dy**2 + dz**2) - pmassi = aprmassoftype(igas,apr_level(ii)) - - ibin = int((rad - radius(1))/dbin + 1) - if ((ibin > nbins) .or. (ibin < 1)) cycle + ! Currently hardwired but this is problematic + rin = 10. + rout = 100. + dbin = (rout-rin)/real(nbins-1) + do ii = 1,nbins + radius(ii) = rin + real(ii-1)*dbin + enddo + + ave_poten = 0. + counter = 0 + ! Create an azimuthally averaged potential energy vs. radius profile + do ii = 1,npart + dx = xyzh(1,ii) - xyzmh_ptmass(1,1) + dy = xyzh(2,ii) - xyzmh_ptmass(2,1) + dz = xyzh(3,ii) - xyzmh_ptmass(3,1) + rad = sqrt(dx**2 + dy**2 + dz**2) + pmassi = aprmassoftype(igas,apr_level(ii)) - ave_poten(ibin) = ave_poten(ibin) + poten(ii)/pmassi - counter(ibin) = counter(ibin) + 1 - enddo + ibin = int((rad - radius(1))/dbin + 1) + if ((ibin > nbins) .or. (ibin < 1)) cycle - ! average with the number of particles in the bin - do ii = 1,nbins - if (counter(ii) > 0) then - ave_poten(ii) = ave_poten(ii)/counter(ii) - else - ave_poten(ii) = 0. - endif - enddo + ave_poten(ibin) = ave_poten(ibin) + poten(ii)/pmassi + counter(ibin) = counter(ibin) + 1 + enddo - ! Identify what radius the local minima are at - minima = 0 - nmins = 0 - do ii = 2, nbins-1 - gradleft = (ave_poten(ii) - ave_poten(ii-1))/(radius(ii) - radius(ii-1)) - gradright = (ave_poten(ii+1) - ave_poten(ii))/(radius(ii+1) - radius(ii)) - if (gradleft * gradright < 0.) then - nmins = nmins + 1 - minima(nmins) = ii - endif - enddo - if (nmins == 0) return - - ! Identify the particles in these minima that have the lowest potential energy - ! this is quite inefficient, in future should save these above into the bins so - ! you just need to cycle through the subset? Don't know if this is faster - minpoten = 1.0 - do jj = 1,nmins - do ii = 1,npart - dx = xyzh(1,ii) - xyzmh_ptmass(1,1) - dy = xyzh(2,ii) - xyzmh_ptmass(2,1) - dz = xyzh(3,ii) - xyzmh_ptmass(3,1) - rad = sqrt(dx**2 + dy**2 + dz**2) - pmassi = aprmassoftype(igas,apr_level(ii)) - - ibin = int((rad - radius(1))/dbin + 1) - if ((ibin == (minima(jj))) .or. & + ! average with the number of particles in the bin + do ii = 1,nbins + if (counter(ii) > 0) then + ave_poten(ii) = ave_poten(ii)/counter(ii) + else + ave_poten(ii) = 0. + endif + enddo + + ! Identify what radius the local minima are at + minima = 0 + nmins = 0 + do ii = 2, nbins-1 + gradleft = (ave_poten(ii) - ave_poten(ii-1))/(radius(ii) - radius(ii-1)) + gradright = (ave_poten(ii+1) - ave_poten(ii))/(radius(ii+1) - radius(ii)) + if (gradleft * gradright < 0.) then + nmins = nmins + 1 + minima(nmins) = ii + endif + enddo + if (nmins == 0) return + + ! Identify the particles in these minima that have the lowest potential energy + ! this is quite inefficient, in future should save these above into the bins so + ! you just need to cycle through the subset? Don't know if this is faster + minpoten = 1.0 + do jj = 1,nmins + do ii = 1,npart + dx = xyzh(1,ii) - xyzmh_ptmass(1,1) + dy = xyzh(2,ii) - xyzmh_ptmass(2,1) + dz = xyzh(3,ii) - xyzmh_ptmass(3,1) + rad = sqrt(dx**2 + dy**2 + dz**2) + pmassi = aprmassoftype(igas,apr_level(ii)) + + ibin = int((rad - radius(1))/dbin + 1) + if ((ibin == (minima(jj))) .or. & (ibin - 1 == (minima(jj))) .or. & (ibin + 1 == (minima(jj)))) then - if ((poten(ii)/pmassi) < minpoten) then - minpoten = poten(ii)/pmassi - min_particle(jj) = ii - endif - endif + if ((poten(ii)/pmassi) < minpoten) then + minpoten = poten(ii)/pmassi + min_particle(jj) = ii + endif + endif enddo - enddo + enddo - ! For the moment, force there to only be one minimum - ! and let it be the lowest - nmins = 1 + ! For the moment, force there to only be one minimum + ! and let it be the lowest + nmins = 1 - ! Check they are not already within a region of low potential energy - ! If they are, replace the existing particle as the one to be tracked - over_mins: do jj = 1,nmins + ! Check they are not already within a region of low potential energy + ! If they are, replace the existing particle as the one to be tracked + over_mins: do jj = 1,nmins ii = min_particle(jj) ! check that the particle at the lowest potential energy has also met the ! density criteria @@ -768,20 +768,20 @@ subroutine create_or_update_apr_clump(npart,xyzh,vxyzu,poten,apr_level,xyzmh_ptm ! get the refinement level of the particle in the middle of the potential call get_apr(xyzh(1:3,ii),apri) if ((ref_dir == -1) .and. (apri == apr_max) .and. (ntrack<1)) then - ! it's a newly identified clump, time to derefine it - ntrack = ntrack + 1 - track_part = ii + ! it's a newly identified clump, time to derefine it + ntrack = ntrack + 1 + track_part = ii else - ! it's an existing clump, update the position of it's centre - track_part = ii + ! it's an existing clump, update the position of it's centre + track_part = ii endif - enddo over_mins - if (ntrack > 0) call set_apr_centre(apr_type,apr_centre,ntrack,track_part) - print*,'tracking ',track_part,ntrack + enddo over_mins + if (ntrack > 0) call set_apr_centre(apr_type,apr_centre,ntrack,track_part) + print*,'tracking ',track_part,ntrack - ! tidy up - deallocate(counter,ave_poten,radius,minima,min_particle) + ! tidy up + deallocate(counter,ave_poten,radius,minima,min_particle) - end subroutine +end subroutine create_or_update_apr_clump end module apr diff --git a/src/main/apr_region.f90 b/src/main/apr_region.f90 index e0eb99806..986c4b943 100644 --- a/src/main/apr_region.f90 +++ b/src/main/apr_region.f90 @@ -16,53 +16,53 @@ module apr_region ! ! :Dependencies: part ! - implicit none + implicit none - logical, public :: dynamic_apr = .false., apr_region_is_circle = .false. - public :: set_apr_centre, set_apr_regions + logical, public :: dynamic_apr = .false., apr_region_is_circle = .false. + public :: set_apr_centre, set_apr_regions - private + private contains - !----------------------------------------------------------------------- - !+ - ! Setting/updating the centre of the apr region (as it may move) - !+ - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- + !+ + ! Setting/updating the centre of the apr region (as it may move) + !+ + !----------------------------------------------------------------------- subroutine set_apr_centre(apr_type,apr_centre,ntrack,track_part) - use part, only: xyzmh_ptmass,xyzh - integer, intent(in) :: apr_type - real, intent(out) :: apr_centre(3) - integer, optional, intent(in) :: ntrack,track_part + use part, only: xyzmh_ptmass,xyzh + integer, intent(in) :: apr_type + real, intent(out) :: apr_centre(3) + integer, optional, intent(in) :: ntrack,track_part - select case (apr_type) + select case (apr_type) - case(1) ! a static circle + case(1) ! a static circle ! do nothing here - case(2) ! around sink particle named track_part + case(2) ! around sink particle named track_part dynamic_apr = .true. apr_centre(1) = xyzmh_ptmass(1,track_part) apr_centre(2) = xyzmh_ptmass(2,track_part) apr_centre(3) = xyzmh_ptmass(3,track_part) - case(3) ! to derefine a clump - only activated when the centre of the clump - ! has been found - dynamic_apr = .true. + case(3) ! to derefine a clump - only activated when the centre of the clump + ! has been found + dynamic_apr = .true. if (present(ntrack)) then - apr_centre(1) = xyzh(1,track_part) - apr_centre(2) = xyzh(2,track_part) - apr_centre(3) = xyzh(3,track_part) + apr_centre(1) = xyzh(1,track_part) + apr_centre(2) = xyzh(2,track_part) + apr_centre(3) = xyzh(3,track_part) else - apr_centre = tiny(apr_centre) ! this *might* be safe? Just want it to be irrelevant + apr_centre = tiny(apr_centre) ! this *might* be safe? Just want it to be irrelevant endif - case default ! used for the test suite + case default ! used for the test suite apr_centre(:) = 0. - end select + end select end subroutine set_apr_centre @@ -74,23 +74,23 @@ end subroutine set_apr_centre !----------------------------------------------------------------------- subroutine set_apr_regions(ref_dir,apr_max,apr_regions,apr_rad,apr_drad) - integer, intent(in) :: ref_dir,apr_max - real, intent(in) :: apr_rad,apr_drad - real, intent(inout) :: apr_regions(apr_max) - integer :: ii,kk + integer, intent(in) :: ref_dir,apr_max + real, intent(in) :: apr_rad,apr_drad + real, intent(inout) :: apr_regions(apr_max) + integer :: ii,kk - if (ref_dir == 1) then + if (ref_dir == 1) then apr_regions(1) = huge(apr_regions(1)) ! this needs to be a number that encompasses the whole domain do ii = 2,apr_max - kk = apr_max - ii + 2 - apr_regions(kk) = apr_rad + (ii-1)*apr_drad + kk = apr_max - ii + 2 + apr_regions(kk) = apr_rad + (ii-1)*apr_drad enddo - else + else apr_regions(apr_max) = huge(apr_regions(apr_max)) ! again this just needs to encompass the whole domain do ii = 1,apr_max-1 - apr_regions(ii) = apr_rad + (ii-1)*apr_drad + apr_regions(ii) = apr_rad + (ii-1)*apr_drad enddo - endif + endif end subroutine set_apr_regions diff --git a/src/main/centreofmass.f90 b/src/main/centreofmass.f90 index debb0efec..20e905ed0 100644 --- a/src/main/centreofmass.f90 +++ b/src/main/centreofmass.f90 @@ -113,17 +113,17 @@ subroutine get_centreofmass(xcom,vcom,npart,xyzh,vxyzu,nptmass,xyzmh_ptmass,vxyz if (maxphase==maxp) then itype = iamtype(iphase(i)) if (itype > 0) then ! avoid problems if called from ICs - if (use_apr) then - pmassi = aprmassoftype(itype,apr_level(i)) - else - pmassi = massoftype(itype) - endif + if (use_apr) then + pmassi = aprmassoftype(itype,apr_level(i)) + else + pmassi = massoftype(itype) + endif else - if (use_apr) then - pmassi = aprmassoftype(igas,apr_level(i)) - else - pmassi = massoftype(igas) - endif + if (use_apr) then + pmassi = aprmassoftype(igas,apr_level(i)) + else + pmassi = massoftype(igas) + endif endif endif totmass = totmass + pmassi @@ -208,17 +208,17 @@ subroutine get_centreofmass_accel(acom,npart,xyzh,fxyzu,fext,nptmass,xyzmh_ptmas hi = xyzh(4,i) if (.not.isdead_or_accreted(hi)) then if (maxphase==maxp) then - if (use_apr) then - pmassi = aprmassoftype(iamtype(iphase(i)),apr_level(i)) - else - pmassi = massoftype(iamtype(iphase(i))) - endif + if (use_apr) then + pmassi = aprmassoftype(iamtype(iphase(i)),apr_level(i)) + else + pmassi = massoftype(iamtype(iphase(i))) + endif else - if (use_apr) then - pmassi = aprmassoftype(igas,apr_level(i)) - else - pmassi = massoftype(igas) - endif + if (use_apr) then + pmassi = aprmassoftype(igas,apr_level(i)) + else + pmassi = massoftype(igas) + endif endif totmass = totmass + pmassi acom(1) = acom(1) + pmassi*(fxyzu(1,i) + fext(1,i)) @@ -296,17 +296,17 @@ subroutine correct_bulk_motion() hi = xyzh(4,i) if (.not.isdead_or_accreted(hi)) then if (maxphase==maxp) then - if (use_apr) then - pmassi = aprmassoftype(iamtype(iphase(i)),apr_level(i)) - else - pmassi = massoftype(iamtype(iphase(i))) - endif + if (use_apr) then + pmassi = aprmassoftype(iamtype(iphase(i)),apr_level(i)) + else + pmassi = massoftype(iamtype(iphase(i))) + endif else - if (use_apr) then - pmassi = aprmassoftype(igas,apr_level(i)) - else - pmassi = massoftype(igas) - endif + if (use_apr) then + pmassi = aprmassoftype(igas,apr_level(i)) + else + pmassi = massoftype(igas) + endif endif totmass = totmass + pmassi @@ -418,9 +418,9 @@ subroutine get_total_angular_momentum(xyzh,vxyz,npart,L_tot,xyzmh_ptmass,vxyz_pt if (.not.isdead_or_accreted(xyzh(4,ii))) then itype = iamtype(iphase(ii)) if (use_apr) then - pmassi = aprmassoftype(itype,apr_level(ii)) + pmassi = aprmassoftype(itype,apr_level(ii)) else - pmassi = massoftype(itype) + pmassi = massoftype(itype) endif call cross_product3D(xyzh(1:3,ii),vxyz(1:3,ii),temp) L_tot = L_tot + temp*pmassi diff --git a/src/main/dens.F90 b/src/main/dens.F90 index cf692d735..d81bc4d5f 100644 --- a/src/main/dens.F90 +++ b/src/main/dens.F90 @@ -741,11 +741,11 @@ pure subroutine get_density_sums(i,xpartveci,hi,hi1,hi21,iamtypei,iamgasi,iamdus ! adjust masses for apr ! this defaults to massoftype if apr_level=1 if (use_apr) then - pmassi = aprmassoftype(iamtypei,apri) - pmassj = aprmassoftype(iamtypej,apr_level(j)) + pmassi = aprmassoftype(iamtypei,apri) + pmassj = aprmassoftype(iamtypej,apr_level(j)) else - pmassi = massoftype(iamtypei) - pmassj = massoftype(iamtypej) + pmassi = massoftype(iamtypei) + pmassj = massoftype(iamtypej) endif sametype: if (same_type) then @@ -1258,9 +1258,9 @@ pure subroutine compute_cell(cell,listneigh,nneigh,getdv,getdB,Bevol,xyzh,vxyzu, hi41 = hi21*hi21 if (use_apr) then - apri = cell%apr(i) + apri = cell%apr(i) else - apri = 1 + apri = 1 endif @@ -1376,9 +1376,9 @@ subroutine start_cell(cell,iphase,xyzh,vxyzu,fxyzu,fext,Bevol,rad,apr_level) if (do_radiation) cell%xpartvec(iradxii,cell%npcell) = rad(iradxi,i) if (use_apr) then - cell%apr(cell%npcell) = apr_level(i) + cell%apr(cell%npcell) = apr_level(i) else - cell%apr(cell%npcell) = 1 + cell%apr(cell%npcell) = 1 endif enddo over_parts @@ -1422,9 +1422,9 @@ subroutine finish_cell(cell,cell_converged) apri = cell%apr(i) if (use_apr) then - pmassi = aprmassoftype(iamtypei,apri) + pmassi = aprmassoftype(iamtypei,apri) else - pmassi = massoftype(iamtypei) + pmassi = massoftype(iamtypei) endif call finish_rhosum(rhosum,pmassi,hi,.true.,rhoi=rhoi,rhohi=rhohi,& @@ -1588,9 +1588,9 @@ subroutine store_results(icall,cell,getdv,getdb,realviscosity,stressmax,xyzh,& apri = cell%apr(i) if (use_apr) then - pmassi = aprmassoftype(iamtypei,apri) + pmassi = aprmassoftype(iamtypei,apri) else - pmassi = massoftype(iamtypei) + pmassi = massoftype(iamtypei) endif if (calculate_density) then diff --git a/src/main/force.F90 b/src/main/force.F90 index 3051acec9..38852ec98 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -675,9 +675,9 @@ subroutine force(icall,npart,xyzh,vxyzu,fxyzu,divcurlv,divcurlB,Bevol,dBevol,& iamtypei = igas endif if (use_apr) then - pmassi = aprmassoftype(iamtypei,apr_level(i)) + pmassi = aprmassoftype(iamtypei,apr_level(i)) else - pmassi = massoftype(iamtypei) + pmassi = massoftype(iamtypei) endif rhoi = rhoh(hi,pmassi) if (rhoi > rho_crit) then @@ -1320,9 +1320,9 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g #endif endif if (use_apr) then - pmassj = aprmassoftype(iamtypej,apr_level(j)) + pmassj = aprmassoftype(iamtypej,apr_level(j)) else - pmassj = massoftype(iamtypej) + pmassj = massoftype(iamtypej) endif fgrav = 0.5*(pmassj*fgravi + pmassi*fgravj) @@ -1952,9 +1952,9 @@ subroutine compute_forces(i,iamgasi,iamdusti,xpartveci,hi,hi1,hi21,hi41,gradhi,g iamtypej = iamtype(iphase(j)) endif if (use_apr) then - pmassj = aprmassoftype(iamtypej,apr_level(j)) + pmassj = aprmassoftype(iamtypej,apr_level(j)) else - pmassj = massoftype(iamtypej) + pmassj = massoftype(iamtypej) endif phii = -rij1 fgravj = fgrav*pmassj @@ -2173,9 +2173,9 @@ subroutine start_cell(cell,iphase,xyzh,vxyzu,gradh,divcurlv,divcurlB,dvdx,Bevol, endif if (use_apr) then - pmassi = aprmassoftype(iamtypei,apr_level(i)) + pmassi = aprmassoftype(iamtypei,apr_level(i)) else - pmassi = massoftype(iamtypei) + pmassi = massoftype(iamtypei) endif hi = xyzh(4,i) @@ -2323,9 +2323,9 @@ subroutine start_cell(cell,iphase,xyzh,vxyzu,gradh,divcurlv,divcurlB,dvdx,Bevol, endif endif if (use_apr) then - cell%apr(cell%npcell) = apr_level(i) + cell%apr(cell%npcell) = apr_level(i) else - cell%apr(cell%npcell) = 1 + cell%apr(cell%npcell) = 1 endif alphai = alpha @@ -2489,9 +2489,9 @@ subroutine compute_cell(cell,listneigh,nneigh,Bevol,xyzh,vxyzu,fxyzu, & i = inodeparts(cell%arr_index(ip)) if (use_apr) then - pmassi = aprmassoftype(iamtypei,cell%apr(ip)) + pmassi = aprmassoftype(iamtypei,cell%apr(ip)) else - pmassi = massoftype(iamtypei) + pmassi = massoftype(iamtypei) endif hi = cell%xpartvec(ihi,ip) @@ -2673,9 +2673,9 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv endif if (use_apr) then - pmassi = aprmassoftype(iamtypei,cell%apr(ip)) + pmassi = aprmassoftype(iamtypei,cell%apr(ip)) else - pmassi = massoftype(iamtypei) + pmassi = massoftype(iamtypei) endif i = inodeparts(cell%arr_index(ip)) diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 219ba620e..85725ab50 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -372,9 +372,9 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) ! initialise apr if it is being used if (use_apr) then - call init_apr(apr_level,ierr) + call init_apr(apr_level,ierr) else - apr_level(:) = 1 + apr_level(:) = 1 endif ! diff --git a/src/main/kdtree.F90 b/src/main/kdtree.F90 index 82847c674..313a67032 100644 --- a/src/main/kdtree.F90 +++ b/src/main/kdtree.F90 @@ -396,7 +396,7 @@ subroutine construct_root_node(np,nproot,irootnode,ndim,xmini,xmaxi,ifirstincell xyzh_soa(nproot,:) = xyzh(:,i) iphase_soa(nproot) = iphase(i) if (use_apr) then - apr_level_soa(nproot) = apr_level(i) + apr_level_soa(nproot) = apr_level(i) endif endif isnotdead enddo @@ -573,15 +573,15 @@ subroutine construct_node(nodeentry, nnode, mymum, level, xmini, xmaxi, npnode, hi = xyzh_soa(i,4) hmax = max(hmax,hi) if (maxphase==maxp) then - if (use_apr) then - pmassi = aprmassoftype(iamtype(iphase_soa(i)),apr_level_soa(i)) - else - pmassi = massoftype(iamtype(iphase_soa(i))) - endif + if (use_apr) then + pmassi = aprmassoftype(iamtype(iphase_soa(i)),apr_level_soa(i)) + else + pmassi = massoftype(iamtype(iphase_soa(i))) + endif fac = pmassi*dfac ! to avoid round-off error elseif (use_apr) then - pmassi = aprmassoftype(igas,apr_level_soa(i)) - fac = pmassi*dfac ! to avoid round-off error + pmassi = aprmassoftype(igas,apr_level_soa(i)) + fac = pmassi*dfac ! to avoid round-off error endif totmass_node = totmass_node + pmassi xcofm = xcofm + fac*xi @@ -597,15 +597,15 @@ subroutine construct_node(nodeentry, nnode, mymum, level, xmini, xmaxi, npnode, hi = xyzh_soa(i,4) hmax = max(hmax,hi) if (maxphase==maxp) then - if (use_apr) then - pmassi = aprmassoftype(iamtype(iphase_soa(i)),apr_level_soa(i)) - else - pmassi = massoftype(iamtype(iphase_soa(i))) - endif + if (use_apr) then + pmassi = aprmassoftype(iamtype(iphase_soa(i)),apr_level_soa(i)) + else + pmassi = massoftype(iamtype(iphase_soa(i))) + endif fac = pmassi*dfac ! to avoid round-off error elseif (use_apr) then - pmassi = aprmassoftype(igas,apr_level_soa(i)) - fac = pmassi*dfac ! to avoid round-off error + pmassi = aprmassoftype(igas,apr_level_soa(i)) + fac = pmassi*dfac ! to avoid round-off error endif totmass_node = totmass_node + pmassi xcofm = xcofm + fac*xi @@ -668,11 +668,11 @@ subroutine construct_node(nodeentry, nnode, mymum, level, xmini, xmaxi, npnode, r2max = max(r2max,dr2) #ifdef GRAVITY if (maxphase==maxp) then - if (use_apr) then - pmassi = aprmassoftype(iamtype(iphase_soa(i)),apr_level_soa(i)) - else - pmassi = massoftype(iamtype(iphase_soa(i))) - endif + if (use_apr) then + pmassi = aprmassoftype(iamtype(iphase_soa(i)),apr_level_soa(i)) + else + pmassi = massoftype(iamtype(iphase_soa(i))) + endif endif quads(1) = quads(1) + pmassi*(3.*dx*dx - dr2) ! Q_xx quads(2) = quads(2) + pmassi*(3.*dx*dy) ! Q_xy = Q_yx @@ -774,16 +774,16 @@ subroutine construct_node(nodeentry, nnode, mymum, level, xmini, xmaxi, npnode, ifirstincell(nnode) = 0 if (npnode > 0) then - if (apr_tree) then - ! apr special sort - only used for merging particles - call special_sort_particles_in_cell(iaxis,inoderange(1,nnode),inoderange(2,nnode),inoderange(1,il),inoderange(2,il),& + if (apr_tree) then + ! apr special sort - only used for merging particles + call special_sort_particles_in_cell(iaxis,inoderange(1,nnode),inoderange(2,nnode),inoderange(1,il),inoderange(2,il),& inoderange(1,ir),inoderange(2,ir),nl,nr,xpivot,xyzh_soa,iphase_soa,inodeparts,& npnode,apr_level_soa) - else - ! regular sort - call sort_particles_in_cell(iaxis,inoderange(1,nnode),inoderange(2,nnode),inoderange(1,il),inoderange(2,il),& + else + ! regular sort + call sort_particles_in_cell(iaxis,inoderange(1,nnode),inoderange(2,nnode),inoderange(1,il),inoderange(2,il),& inoderange(1,ir),inoderange(2,ir),nl,nr,xpivot,xyzh_soa,iphase_soa,inodeparts,apr_level_soa) - endif + endif if (nr + nl /= npnode) then call error('maketree','number of left + right != parent while splitting (likely cause: NaNs in position arrays)') @@ -947,7 +947,7 @@ subroutine special_sort_particles_in_cell(iaxis,imin,imax,min_l,max_l,min_r,max_ nchild_in = 2 if (modulo(npnode,nchild_in) > 0) then - call error('apr sort','number of particles sent in to kdtree is not divisible by 2') + call error('apr sort','number of particles sent in to kdtree is not divisible by 2') endif ! print*,'nnode ',imin,imax,npnode,' pivot = ',iaxis,xpivot @@ -999,12 +999,12 @@ subroutine special_sort_particles_in_cell(iaxis,imin,imax,min_l,max_l,min_r,max_ enddo if (.not.i_lt_pivot) then - i = i - 1 - dpivot(i-imin+1) = xpivot - xyzh_soa(i,iaxis) + i = i - 1 + dpivot(i-imin+1) = xpivot - xyzh_soa(i,iaxis) endif if (j_lt_pivot) then - j = j + 1 - dpivot(j-imin+1) = xpivot - xyzh_soa(j,iaxis) + j = j + 1 + dpivot(j-imin+1) = xpivot - xyzh_soa(j,iaxis) endif min_l = imin @@ -1023,76 +1023,76 @@ subroutine special_sort_particles_in_cell(iaxis,imin,imax,min_l,max_l,min_r,max_ ! Decide which direction the pivot needs to go if (rem_nl < rem_nr) then - slide_l = .true. - slide_r = .false. + slide_l = .true. + slide_r = .false. else - slide_l = .false. - slide_r = .true. + slide_l = .false. + slide_r = .true. endif ! Override this if there's less than nchild*2 in the cell if (nl < nchild_in) then - slide_r = .true. - slide_l = .false. + slide_r = .true. + slide_l = .false. elseif (nr < nchild_in) then - slide_r = .false. - slide_l = .true. + slide_r = .false. + slide_l = .true. endif ! Move across particles by distance from xpivot till we get ! the right number of particles in each cell if (slide_r) then - do ii = 1,rem_nr - ! next particle to shift across - k = minloc(dpivot,dim=1,mask=dpivot > 0.) + imin - 1 - if (k-imin+1==0) k = maxloc(dpivot,dim=1,mask=dpivot < 0.) + imin - 1 - - ! swap this with the first particle on the j side - inodeparts_swap = inodeparts(k) - xyzh_swap(1:4) = xyzh_soa(k,1:4) - iphase_swap = iphase_soa(k) - - inodeparts(k) = inodeparts(j) - xyzh_soa(k,1:4) = xyzh_soa(j,1:4) - iphase_soa(k) = iphase_soa(j) - - inodeparts(j) = inodeparts_swap - xyzh_soa(j,1:4) = xyzh_swap(1:4) - iphase_soa(j) = iphase_swap - - ! and now shift to the right - i = i + 1 - j = j + 1 - - ! ditch it, go again - dpivot(k-imin+1) = huge(k-imin+1) - enddo + do ii = 1,rem_nr + ! next particle to shift across + k = minloc(dpivot,dim=1,mask=dpivot > 0.) + imin - 1 + if (k-imin+1==0) k = maxloc(dpivot,dim=1,mask=dpivot < 0.) + imin - 1 + + ! swap this with the first particle on the j side + inodeparts_swap = inodeparts(k) + xyzh_swap(1:4) = xyzh_soa(k,1:4) + iphase_swap = iphase_soa(k) + + inodeparts(k) = inodeparts(j) + xyzh_soa(k,1:4) = xyzh_soa(j,1:4) + iphase_soa(k) = iphase_soa(j) + + inodeparts(j) = inodeparts_swap + xyzh_soa(j,1:4) = xyzh_swap(1:4) + iphase_soa(j) = iphase_swap + + ! and now shift to the right + i = i + 1 + j = j + 1 + + ! ditch it, go again + dpivot(k-imin+1) = huge(k-imin+1) + enddo else - do ii = 1,rem_nl - ! next particle to shift across - k = maxloc(dpivot,dim=1,mask=dpivot < 0.) + imin - 1 - if (k-imin+1==0) k = minloc(dpivot,dim=1,mask=dpivot > 0.) + imin - 1 + do ii = 1,rem_nl + ! next particle to shift across + k = maxloc(dpivot,dim=1,mask=dpivot < 0.) + imin - 1 + if (k-imin+1==0) k = minloc(dpivot,dim=1,mask=dpivot > 0.) + imin - 1 - ! swap this with the last particle on the i side - inodeparts_swap = inodeparts(k) - xyzh_swap(1:4) = xyzh_soa(k,1:4) - iphase_swap = iphase_soa(k) + ! swap this with the last particle on the i side + inodeparts_swap = inodeparts(k) + xyzh_swap(1:4) = xyzh_soa(k,1:4) + iphase_swap = iphase_soa(k) - inodeparts(k) = inodeparts(i) - xyzh_soa(k,1:4) = xyzh_soa(i,1:4) - iphase_soa(k) = iphase_soa(i) + inodeparts(k) = inodeparts(i) + xyzh_soa(k,1:4) = xyzh_soa(i,1:4) + iphase_soa(k) = iphase_soa(i) - inodeparts(i) = inodeparts_swap - xyzh_soa(i,1:4) = xyzh_swap(1:4) - iphase_soa(i) = iphase_swap + inodeparts(i) = inodeparts_swap + xyzh_soa(i,1:4) = xyzh_swap(1:4) + iphase_soa(i) = iphase_swap - ! and now shift to the left - i = i - 1 - j = j - 1 + ! and now shift to the left + i = i - 1 + j = j - 1 - ! ditch it, go again - dpivot(k-imin+1) = huge(k-imin+1) + ! ditch it, go again + dpivot(k-imin+1) = huge(k-imin+1) - enddo + enddo endif ! tidy up outputs @@ -1534,9 +1534,9 @@ subroutine revtree(node, xyzh, ifirstincell, ncells) zi = xyzh(3,i) if (maxphase==maxp) then if (use_apr) then - pmassi = aprmassoftype(iamtype(iphase(i)),apr_level(i)) + pmassi = aprmassoftype(iamtype(iphase(i)),apr_level(i)) else - pmassi = massoftype(iamtype(iphase(i))) + pmassi = massoftype(iamtype(iphase(i))) endif endif x0(1) = x0(1) + pmassi*xi @@ -1575,11 +1575,11 @@ subroutine revtree(node, xyzh, ifirstincell, ncells) hmax = max(hi, hmax) #ifdef GRAVITY if (maxphase==maxp) then - if (use_apr) then - pmassi = aprmassoftype(iamtype(iphase(i)),apr_level(i)) - else - pmassi = massoftype(iamtype(iphase(i))) - endif + if (use_apr) then + pmassi = aprmassoftype(iamtype(iphase(i)),apr_level(i)) + else + pmassi = massoftype(iamtype(iphase(i))) + endif endif quads(1) = quads(1) + pmassi*(3.*dx*dx - dr2) quads(2) = quads(2) + pmassi*(3.*dx*dy) @@ -1836,7 +1836,7 @@ subroutine maketreeglobal(nodeglobal,node,nodemap,globallevel,refinelevels,xyzh, xyzh_soa(npnode,:) = xyzh(:,i) iphase_soa(npnode) = iphase(i) if (use_apr) then - apr_level_soa(npnode) = apr_level(i) + apr_level_soa(npnode) = apr_level(i) endif enddo diff --git a/src/main/part.F90 b/src/main/part.F90 index e157dd7fa..5d79d7c66 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -1250,7 +1250,7 @@ subroutine copy_particle(src,dst,new_part) dustevol(:,dst) = dustevol(:,src) endif if (use_apr) then - apr_level(dst) = apr_level(src) + apr_level(dst) = apr_level(src) endif if (maxp_h2==maxp .or. maxp_krome==maxp) abundance(:,dst) = abundance(:,src) eos_vars(:,dst) = eos_vars(:,src) @@ -1370,8 +1370,8 @@ subroutine copy_particle_all(src,dst,new_part) ibin_sts(dst) = ibin_sts(src) endif if (use_apr) then - apr_level(dst) = apr_level(src) - apr_level_soa(dst) = apr_level_soa(src) + apr_level(dst) = apr_level(src) + apr_level_soa(dst) = apr_level_soa(src) endif if (new_part) then @@ -1591,7 +1591,7 @@ subroutine fill_sendbuf(i,xtemp,nbuf) call fill_buffer(xtemp,twas(i),nbuf) endif call fill_buffer(xtemp,iorig(i),nbuf) - ! call fill_buffer(xtemp,apr_level(i),nbuf) + ! call fill_buffer(xtemp,apr_level(i),nbuf) endif if (nbuf > ipartbufsize) call fatal('fill_sendbuf','error: send buffer size overflow',var='nbuf',ival=nbuf) diff --git a/src/main/relaxem.f90 b/src/main/relaxem.f90 index 61b96b8d0..fc7ab99af 100644 --- a/src/main/relaxem.f90 +++ b/src/main/relaxem.f90 @@ -17,35 +17,35 @@ module relaxem ! :Dependencies: boundary, deriv, dim, eos, kernel, mpidomain, options, ! part ! - implicit none + implicit none contains ! Subroutine to relax the new set of particles to a reference particle distribution subroutine relax_particles(npart,n_ref,xyzh_ref,force_ref,nrelax,relaxlist) - use deriv, only:get_derivs_global - integer, intent(in) :: npart,n_ref,nrelax - real, intent(in) :: force_ref(3,n_ref),xyzh_ref(4,n_ref) - integer, intent(in) :: relaxlist(1:nrelax) - real, allocatable :: a_ref(:,:) - real :: ke,maxshift,ke_init,shuffle_tol - logical :: converged - integer :: ishift,nshifts + use deriv, only:get_derivs_global + integer, intent(in) :: npart,n_ref,nrelax + real, intent(in) :: force_ref(3,n_ref),xyzh_ref(4,n_ref) + integer, intent(in) :: relaxlist(1:nrelax) + real, allocatable :: a_ref(:,:) + real :: ke,maxshift,ke_init,shuffle_tol + logical :: converged + integer :: ishift,nshifts - write(*,"(/,70('-'),/,/,2x,a,/,/)") 'APR: time to relax ...' + write(*,"(/,70('-'),/,/,2x,a,/,/)") 'APR: time to relax ...' - write(*,"(1x,1(a,i8,a,i8,a))") 'Relaxing',nrelax,' particles the heavenly way from',n_ref,' references.' + write(*,"(1x,1(a,i8,a,i8,a))") 'Relaxing',nrelax,' particles the heavenly way from',n_ref,' references.' - ! Initialise for the loop - converged = .false. - ishift = 0 - nshifts = 50 - shuffle_tol = 0.05 + ! Initialise for the loop + converged = .false. + ishift = 0 + nshifts = 50 + shuffle_tol = 0.05 - ! a_ref stores the accelerations at the locations of the new particles as interpolated from the old ones - allocate(a_ref(3,npart)) + ! a_ref stores the accelerations at the locations of the new particles as interpolated from the old ones + allocate(a_ref(3,npart)) - do while (.not.converged) + do while (.not.converged) ! This gets fxyz of the new particles at their new locations call get_derivs_global() @@ -65,12 +65,12 @@ subroutine relax_particles(npart,n_ref,xyzh_ref,force_ref,nrelax,relaxlist) if (ishift >= nshifts .or. (ke/ke_init < shuffle_tol)) converged = .true. ishift = ishift + 1 - enddo + enddo - ! Tidy up - deallocate(a_ref) + ! Tidy up + deallocate(a_ref) - write(*,"(/,/,2x,a,/,/,70('-'))") 'APR: relaxing finished.' + write(*,"(/,/,2x,a,/,/,70('-'))") 'APR: relaxing finished.' end subroutine relax_particles @@ -83,27 +83,27 @@ end subroutine relax_particles subroutine get_reference_accelerations(npart,a_ref,n_ref,xyzh_ref,& force_ref,nrelax,relaxlist) - use part, only:xyzh,aprmassoftype,igas,apr_level,rhoh - use dim, only:periodic - use kernel, only:wkern,grkern,radkern2,cnormk - use boundary, only:dxbound,dybound,dzbound - integer, intent(in) :: npart,n_ref,nrelax - real, intent(in) :: force_ref(3,n_ref),xyzh_ref(4,n_ref) - integer, intent(in) :: relaxlist(nrelax) - real, intent(out) :: a_ref(3,npart) - real :: xi,yi,zi,rij(3),h21,qj2,rij2,rhoj,h31,mass_ref,pmassi - integer :: i,j,k - - a_ref(:,:) = 0. - - ! Over the new set of particles that are to be shuffled - !$omp parallel do schedule(guided) default (none) & - !$omp shared(xyzh,xyzh_ref,npart,n_ref,force_ref,a_ref,relaxlist) & - !$omp shared(nrelax,apr_level,dxbound,dybound,dzbound) & - !$omp shared(mass_ref,aprmassoftype) & - !$omp private(i,j,xi,yi,zi,rij,h21,h31,rhoj,rij2,qj2,pmassi) - - over_new: do k = 1,nrelax + use part, only:xyzh,aprmassoftype,igas,apr_level,rhoh + use dim, only:periodic + use kernel, only:wkern,grkern,radkern2,cnormk + use boundary, only:dxbound,dybound,dzbound + integer, intent(in) :: npart,n_ref,nrelax + real, intent(in) :: force_ref(3,n_ref),xyzh_ref(4,n_ref) + integer, intent(in) :: relaxlist(nrelax) + real, intent(out) :: a_ref(3,npart) + real :: xi,yi,zi,rij(3),h21,qj2,rij2,rhoj,h31,mass_ref,pmassi + integer :: i,j,k + + a_ref(:,:) = 0. + + ! Over the new set of particles that are to be shuffled + !$omp parallel do schedule(guided) default (none) & + !$omp shared(xyzh,xyzh_ref,npart,n_ref,force_ref,a_ref,relaxlist) & + !$omp shared(nrelax,apr_level,dxbound,dybound,dzbound) & + !$omp shared(mass_ref,aprmassoftype) & + !$omp private(i,j,xi,yi,zi,rij,h21,h31,rhoj,rij2,qj2,pmassi) + + over_new: do k = 1,nrelax if (relaxlist(k) == 0) cycle over_new i = relaxlist(k) xi = xyzh(1,i) @@ -113,32 +113,32 @@ subroutine get_reference_accelerations(npart,a_ref,n_ref,xyzh_ref,& ! Over the reference set of particles to which we are matching the accelerations over_reference: do j = 1,n_ref ! later this should only be over active particles - rij(1) = xyzh_ref(1,j) - xi - rij(2) = xyzh_ref(2,j) - yi - rij(3) = xyzh_ref(3,j) - zi - mass_ref = aprmassoftype(igas,apr_level(j)) ! TBD: fix this to allow for dust + rij(1) = xyzh_ref(1,j) - xi + rij(2) = xyzh_ref(2,j) - yi + rij(3) = xyzh_ref(3,j) - zi + mass_ref = aprmassoftype(igas,apr_level(j)) ! TBD: fix this to allow for dust - if (periodic) then - if (abs(rij(1)) > 0.5*dxbound) rij(1) = rij(1) - dxbound*SIGN(1.0,rij(1)) - if (abs(rij(2)) > 0.5*dybound) rij(2) = rij(2) - dybound*SIGN(1.0,rij(2)) - if (abs(rij(3)) > 0.5*dzbound) rij(3) = rij(3) - dzbound*SIGN(1.0,rij(3)) - endif + if (periodic) then + if (abs(rij(1)) > 0.5*dxbound) rij(1) = rij(1) - dxbound*SIGN(1.0,rij(1)) + if (abs(rij(2)) > 0.5*dybound) rij(2) = rij(2) - dybound*SIGN(1.0,rij(2)) + if (abs(rij(3)) > 0.5*dzbound) rij(3) = rij(3) - dzbound*SIGN(1.0,rij(3)) + endif - h21 = 1./(xyzh_ref(4,j))**2 - h31 = 1./(xyzh_ref(4,j))**3 - rhoj = rhoh(xyzh_ref(4,j),mass_ref) + h21 = 1./(xyzh_ref(4,j))**2 + h31 = 1./(xyzh_ref(4,j))**3 + rhoj = rhoh(xyzh_ref(4,j),mass_ref) - rij2 = dot_product(rij,rij) - qj2 = rij2*h21 + rij2 = dot_product(rij,rij) + qj2 = rij2*h21 - if (qj2 < radkern2) then - ! Interpolate acceleration at the location of the new particle - a_ref(:,i) = a_ref(:,i) + force_ref(:,j)*wkern(qj2,sqrt(qj2))*cnormk*h31/rhoj - endif + if (qj2 < radkern2) then + ! Interpolate acceleration at the location of the new particle + a_ref(:,i) = a_ref(:,i) + force_ref(:,j)*wkern(qj2,sqrt(qj2))*cnormk*h31/rhoj + endif enddo over_reference - enddo over_new - !$omp end parallel do + enddo over_new + !$omp end parallel do end subroutine get_reference_accelerations @@ -151,34 +151,34 @@ end subroutine get_reference_accelerations !---------------------------------------------------------------- subroutine shift_particles(npart,a_ref,nrelax,relaxlist,ke,maxshift) - use dim, only:periodic - use part, only:xyzh,vxyzu,fxyzu,igas,aprmassoftype,rhoh, & + use dim, only:periodic + use part, only:xyzh,vxyzu,fxyzu,igas,aprmassoftype,rhoh, & apr_level - use eos, only:get_spsound - use options, only:ieos - use boundary, only:cross_boundary - use mpidomain, only: isperiodic - integer, intent(in) :: npart,nrelax - real, intent(in) :: a_ref(3,npart) - integer, intent(in) :: relaxlist(nrelax) - real, intent(out) :: ke,maxshift - real :: hi,rhoi,cs,dti,dx(3),vi(3),err,pri,limit_bound - real :: pmassi - integer :: nlargeshift,i,ncross,j,m - - ke = 0. - nlargeshift = 0 - ncross = 0 - maxshift = tiny(maxshift) - limit_bound = 0.4 !! This probably shouldn't be more than 0.5 - - !$omp parallel do schedule(guided) default(none) & - !$omp shared(npart,xyzh,vxyzu,fxyzu,ieos,a_ref,maxshift) & - !$omp shared(apr_level,aprmassoftype) & - !$omp shared(isperiodic,ncross,relaxlist,nrelax) & - !$omp private(i,dx,dti,cs,rhoi,hi,vi,err,pri,m,pmassi) & - !$omp reduction(+:nlargeshift,ke) - do j=1,nrelax + use eos, only:get_spsound + use options, only:ieos + use boundary, only:cross_boundary + use mpidomain, only: isperiodic + integer, intent(in) :: npart,nrelax + real, intent(in) :: a_ref(3,npart) + integer, intent(in) :: relaxlist(nrelax) + real, intent(out) :: ke,maxshift + real :: hi,rhoi,cs,dti,dx(3),vi(3),err,pri,limit_bound + real :: pmassi + integer :: nlargeshift,i,ncross,j,m + + ke = 0. + nlargeshift = 0 + ncross = 0 + maxshift = tiny(maxshift) + limit_bound = 0.4 !! This probably shouldn't be more than 0.5 + + !$omp parallel do schedule(guided) default(none) & + !$omp shared(npart,xyzh,vxyzu,fxyzu,ieos,a_ref,maxshift) & + !$omp shared(apr_level,aprmassoftype) & + !$omp shared(isperiodic,ncross,relaxlist,nrelax) & + !$omp private(i,dx,dti,cs,rhoi,hi,vi,err,pri,m,pmassi) & + !$omp reduction(+:nlargeshift,ke) + do j=1,nrelax if (relaxlist(j) == 0) cycle i = relaxlist(j) hi = xyzh(4,i) @@ -191,8 +191,8 @@ subroutine shift_particles(npart,a_ref,nrelax,relaxlist,ke,maxshift) if (sqrt(dot_product(dx,dx)) > maxshift) maxshift = sqrt(dot_product(dx,dx)) if (dot_product(dx,dx) > hi**2) then - dx = dx / sqrt(dot_product(dx,dx)) * hi ! Avoid large shift in particle position !check with what James has done - nlargeshift = nlargeshift + 1 + dx = dx / sqrt(dot_product(dx,dx)) * hi ! Avoid large shift in particle position !check with what James has done + nlargeshift = nlargeshift + 1 endif ! actual shift @@ -210,9 +210,9 @@ subroutine shift_particles(npart,a_ref,nrelax,relaxlist,ke,maxshift) err = sqrt(dot_product(dx,dx))/hi if (err > maxshift) maxshift = err - enddo - !$omp end parallel do - if (nlargeshift > 0) print*,'Warning: Restricted dx for ', nlargeshift, 'particles' + enddo + !$omp end parallel do + if (nlargeshift > 0) print*,'Warning: Restricted dx for ', nlargeshift, 'particles' end subroutine shift_particles @@ -226,25 +226,25 @@ end subroutine shift_particles !---------------------------------------------------------------- subroutine check_for_pairing(nrelax,relaxlist,pair_distance) - use part, only:xyzh - integer, intent(in) :: nrelax,relaxlist(nrelax) - real, intent(out) :: pair_distance - real :: dx(3), dx_mag - integer :: ii,jj + use part, only:xyzh + integer, intent(in) :: nrelax,relaxlist(nrelax) + real, intent(out) :: pair_distance + real :: dx(3), dx_mag + integer :: ii,jj - pair_distance = huge(pair_distance) + pair_distance = huge(pair_distance) - do ii = 1,nrelax + do ii = 1,nrelax do jj = 1,nrelax - if (ii == jj) cycle - dx = xyzh(1:3,ii) - xyzh(1:3,jj) - dx_mag = sqrt(dot_product(dx,dx))/xyzh(4,ii) ! scaled by the smoothing length + if (ii == jj) cycle + dx = xyzh(1:3,ii) - xyzh(1:3,jj) + dx_mag = sqrt(dot_product(dx,dx))/xyzh(4,ii) ! scaled by the smoothing length - if (dx_mag < pair_distance) pair_distance = dx_mag + if (dx_mag < pair_distance) pair_distance = dx_mag enddo - enddo + enddo - end subroutine check_for_pairing +end subroutine check_for_pairing end module relaxem diff --git a/src/setup/relax_star.f90 b/src/setup/relax_star.f90 index df6c82d8f..41d9e450d 100644 --- a/src/setup/relax_star.f90 +++ b/src/setup/relax_star.f90 @@ -147,9 +147,9 @@ subroutine relax_star(nt,rho,pr,r,npart,xyzh,use_var_comp,Xfrac,Yfrac,mu,ierr,np ! if using apr, options set in setup file but needs to be initialised here if (use_apr) then - call allocate_linklist - call init_apr(apr_level,ierr) - call update_apr(npart,xyzh,vxyzu,fxyzu,apr_level) + call allocate_linklist + call init_apr(apr_level,ierr) + call update_apr(npart,xyzh,vxyzu,fxyzu,apr_level) endif @@ -342,9 +342,9 @@ subroutine shift_particles(i1,npart,xyzh,vxyzu,dtmin) endif hi = xyzh(4,i) if (use_apr) then - pmassi = aprmassoftype(igas,apr_level(i)) + pmassi = aprmassoftype(igas,apr_level(i)) else - pmassi = massoftype(igas) + pmassi = massoftype(igas) endif rhoi = rhoh(hi,pmassi) cs = get_spsound(ieos,xyzh(:,i),rhoi,vxyzu(:,i)) @@ -407,27 +407,27 @@ subroutine reset_u_and_get_errors(i1,npart,xyzh,vxyzu,rad,nt,mr,rho,& massrj = 0. do i = i1+1,npart - if (use_apr) then - rankj = minval(iorder,mask=iorder_mask) ! Start from innermost to outermost particles - j = sum(minloc(iorder,mask=iorder_mask)) ! ID of first particle with iorder==rankj. Ignore the sum, doesn't do anything in practice. - iorder_mask(j) = .false. ! Eliminate this particle from next loop - npart_with_rank_prev = count(iorder==rank_prev) ! note that this is 0 for rankj=1 - pmassj = aprmassoftype(igas,apr_level(j)) ! replace with actual particle mass - else - j = i - pmassj = massoftype(igas) ! replace with actual particle mass - endif - - rj = sqrt(dot_product(xyzh(1:3,j),xyzh(1:3,j))) - - if (use_apr) then - if (rankj/=rank_prev) massrj = massrj + real(npart_with_rank_prev)*pmassj ! for rankj=1, this correctly gives 0 - rank_prev = rankj - else - massrj = mstar * real(iorder(i-i1)-1) / real(npart-i1) - endif - ! print*,'rankj=',rankj,'rank_prev=',rank_prev,'npartwithrankprev=',npart_with_rank_prev,'rj=',rj,'massri/pmass=',massrj/pmassj - ! read* + if (use_apr) then + rankj = minval(iorder,mask=iorder_mask) ! Start from innermost to outermost particles + j = sum(minloc(iorder,mask=iorder_mask)) ! ID of first particle with iorder==rankj. Ignore the sum, doesn't do anything in practice. + iorder_mask(j) = .false. ! Eliminate this particle from next loop + npart_with_rank_prev = count(iorder==rank_prev) ! note that this is 0 for rankj=1 + pmassj = aprmassoftype(igas,apr_level(j)) ! replace with actual particle mass + else + j = i + pmassj = massoftype(igas) ! replace with actual particle mass + endif + + rj = sqrt(dot_product(xyzh(1:3,j),xyzh(1:3,j))) + + if (use_apr) then + if (rankj/=rank_prev) massrj = massrj + real(npart_with_rank_prev)*pmassj ! for rankj=1, this correctly gives 0 + rank_prev = rankj + else + massrj = mstar * real(iorder(i-i1)-1) / real(npart-i1) + endif + ! print*,'rankj=',rankj,'rank_prev=',rank_prev,'npartwithrankprev=',npart_with_rank_prev,'rj=',rj,'massri/pmass=',massrj/pmassj + ! read* rhor = yinterp(rho,mr,massrj) ! analytic rho(r) rhoj = rhoh(xyzh(4,j),pmassj) ! actual rho diff --git a/src/setup/setup_star.f90 b/src/setup/setup_star.f90 index 58250ed2b..a0d5f5020 100644 --- a/src/setup/setup_star.f90 +++ b/src/setup/setup_star.f90 @@ -304,7 +304,7 @@ subroutine write_setupfile(filename,gamma,polyk) if (use_apr) then write(iunit,"(/,a)") '# apr options' - call write_options_apr(iunit) + call write_options_apr(iunit) endif close(iunit) @@ -385,11 +385,11 @@ subroutine read_setupfile(filename,gamma,polyk,need_iso,ierr) endif if (use_apr) then - call read_inopt(apr_max_in,'apr_max',db) - call read_inopt(ref_dir,'ref_dir',db) - call read_inopt(apr_type,'apr_type',db) - call read_inopt(apr_rad,'apr_rad',db) - call read_inopt(apr_drad,'apr_drad',db) + call read_inopt(apr_max_in,'apr_max',db) + call read_inopt(ref_dir,'ref_dir',db) + call read_inopt(apr_type,'apr_type',db) + call read_inopt(apr_rad,'apr_rad',db) + call read_inopt(apr_drad,'apr_drad',db) endif call close_db(db) diff --git a/src/tests/directsum.f90 b/src/tests/directsum.f90 index 2a1c5b720..d4ac696f5 100644 --- a/src/tests/directsum.f90 +++ b/src/tests/directsum.f90 @@ -98,12 +98,12 @@ subroutine directsum_grav(xyzh,gradh,fgrav,phitot,ntot) iamtypei = iamtype(iphase(i)) iactivei = iactive(iphase(i)) if (use_apr) then - pmassi = aprmassoftype(iamtypei,apr_level(i)) + pmassi = aprmassoftype(iamtypei,apr_level(i)) else - pmassi = massoftype(iamtypei) + pmassi = massoftype(iamtypei) endif else - if (use_apr) pmassi = aprmassoftype(igas,apr_level(i)) + if (use_apr) pmassi = aprmassoftype(igas,apr_level(i)) endif hi1 = 1./hi diff --git a/src/tests/test_apr.f90 b/src/tests/test_apr.f90 index 358757dd7..8790d53c0 100644 --- a/src/tests/test_apr.f90 +++ b/src/tests/test_apr.f90 @@ -83,9 +83,9 @@ subroutine test_apr(ntests,npass) ! Check that the original particle number returns if (npart == original_npart) then - npass = 1 + npass = 1 else - npass = 0 + npass = 0 endif if (id==master) write(*,"(/,a)") '<-- APR TEST COMPLETE' @@ -108,11 +108,11 @@ subroutine setup_apr_region_for_test() if (id==master) write(*,"(/,a)") '--> adding an apr region' ! set parameters for the region - apr_max_in = 1 ! number of additional refinement levels (3 -> 2x resolution) - ref_dir = 1 ! increase (1) or decrease (-1) resolution - apr_type = -1 ! choose this so you get the default option which is - ! reserved for the test suite - apr_rad = 0.25 ! radius of innermost region + apr_max_in = 1 ! number of additional refinement levels (3 -> 2x resolution) + ref_dir = 1 ! increase (1) or decrease (-1) resolution + apr_type = -1 ! choose this so you get the default option which is + ! reserved for the test suite + apr_rad = 0.25 ! radius of innermost region ! initialise diff --git a/src/tests/testsuite.F90 b/src/tests/testsuite.F90 index bf638c33b..a33837b84 100644 --- a/src/tests/testsuite.F90 +++ b/src/tests/testsuite.F90 @@ -225,12 +225,12 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) ! !--apr test ! -if (use_apr.and.testall) then - write(*,*) '-DAPR not currently compatible with test suite, recompile with APR=no' - return -elseif (use_apr.and.doapr) then - call test_apr(ntests,npass) -endif + if (use_apr.and.testall) then + write(*,*) '-DAPR not currently compatible with test suite, recompile with APR=no' + return + elseif (use_apr.and.doapr) then + call test_apr(ntests,npass) + endif ! !--test kernel module diff --git a/src/utils/utils_disc.f90 b/src/utils/utils_disc.f90 index bd38dd3a4..0e47329c6 100644 --- a/src/utils/utils_disc.f90 +++ b/src/utils/utils_disc.f90 @@ -110,7 +110,7 @@ subroutine disc_analysis(xyzh,vxyz,npart,pmass,time,nbin,rmin,rmax,G,M_star,& if (allocated(zsetgas)) deallocate(zsetgas) allocate(myz(npart)) else - allocate(myz(0)) ! to prevent compiler warnings + allocate(myz(0)) ! to prevent compiler warnings endif ! Move everything so that the centre of mass is at the origin From 3b81be710ed4ee9bf3978e3599cf6d3adcdabdf3 Mon Sep 17 00:00:00 2001 From: Rebecca Nealon Date: Wed, 16 Oct 2024 11:35:41 +0100 Subject: [PATCH 058/134] (apr) bug fix --- src/main/mpi_dens.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/mpi_dens.F90 b/src/main/mpi_dens.F90 index d588ad26f..19ef900ae 100644 --- a/src/main/mpi_dens.F90 +++ b/src/main/mpi_dens.F90 @@ -27,7 +27,7 @@ module mpidens public :: get_mpitype_of_celldens public :: free_mpitype_of_celldens - integer, parameter :: ndata = 18 ! number of elements in the cell (including padding) + integer, parameter :: ndata = 19 ! number of elements in the cell (including padding) integer, parameter :: nbytes_celldens = 8 * minpart + & ! h(minpart) 8 * minpart + & ! h_old(minpart) 8 * maxxpartvecidens * minpart + & ! xpartvec(maxxpartvecidens,minpart) From 0647f6140a20b07abeb39ce67bea8a506cfa7fe6 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Wed, 16 Oct 2024 13:48:04 +0100 Subject: [PATCH 059/134] fixes for Github build --- src/main/force.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/main/force.F90 b/src/main/force.F90 index 5ed29ff4f..bc3096671 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -2617,7 +2617,10 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv use part, only:Omega_k use io, only:warning use physcon, only:c,kboltz - use eos_stamatellos, only:Gpot_cool,duSPH +#ifdef GRAVITY + use eos_stamatellos, only:Gpot_cool +#endif + use eos_stamatellos, only:duSPH integer, intent(in) :: icall type(cellforce), intent(inout) :: cell real, intent(inout) :: fxyzu(:,:) @@ -2687,7 +2690,6 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv real :: densi, vxi,vyi,vzi,u0i,dudtcool,dudtheat real :: posi(3),veli(3),gcov(0:3,0:3),metrici(0:3,0:3,2) integer :: ii,ia,ib,ic,ierror - eni = 0. realviscosity = (irealvisc > 0) From 3250295ee990ab6124d0b1329cf462dbf19a3622 Mon Sep 17 00:00:00 2001 From: Rebecca Nealon Date: Wed, 16 Oct 2024 17:32:18 +0100 Subject: [PATCH 060/134] (apr) bug fix --- src/main/mpi_force.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/mpi_force.F90 b/src/main/mpi_force.F90 index a0a944ec1..7a6def3f5 100644 --- a/src/main/mpi_force.F90 +++ b/src/main/mpi_force.F90 @@ -27,7 +27,7 @@ module mpiforce public :: get_mpitype_of_cellforce public :: free_mpitype_of_cellforce - integer, parameter :: ndata = 19 ! number of elements in the cell (including padding) + integer, parameter :: ndata = 20 ! number of elements in the cell (including padding) integer, parameter :: nbytes_cellforce = 8 * maxxpartveciforce * minpart + & ! xpartvec(maxxpartveciforce,minpart) 8 * maxfsum * minpart + & ! fsums(maxfsum,minpart) 8 * 20 + & ! fgrav(20) From a4213a6047deb797740d8b489f1188c637e19ebe Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 17 Oct 2024 15:14:02 +1100 Subject: [PATCH 061/134] (apr) revert changes to setup_wave.f90 --- src/setup/setup_wave.f90 | 26 ++++++++------------------ 1 file changed, 8 insertions(+), 18 deletions(-) diff --git a/src/setup/setup_wave.f90 b/src/setup/setup_wave.f90 index a124285f1..3a0816ee0 100644 --- a/src/setup/setup_wave.f90 +++ b/src/setup/setup_wave.f90 @@ -15,8 +15,7 @@ module setup ! :Runtime parameters: None ! ! :Dependencies: boundary, dim, dust, io, kernel, mpidomain, mpiutils, -! options, part, physcon, prompting, random, set_dust, setup_params, -! unifdis +! options, part, physcon, prompting, set_dust, setup_params, unifdis ! implicit none public :: setpart @@ -45,7 +44,6 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use dust, only:K_code,idrag use set_dust, only:set_dustfrac use mpidomain, only:i_belong - use random, only:ran2 integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) @@ -56,7 +54,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, real, intent(inout) :: time character(len=20), intent(in) :: fileprefix real :: totmass,fac,deltax,deltay,deltaz - integer :: i, iseed=4 + integer :: i integer :: itype,itypes,ntypes,npartx integer :: npart_previous,dust_method logical, parameter :: ishift_box =.true. @@ -70,14 +68,13 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! npartx = 64 ntypes = 1 - rhozero = 1.5 !1. + rhozero = 1. massfac = 1. - cs = 1.0 !2.236 !1. - ampl = 2.d-2 + cs = 1. + ampl = 1.d-4 use_dustfrac = .false. ndustsmall = 0 ndustlarge = 0 - if (id==master) then itype = 1 print "(/,a,/)",' >>> Setting up particles for linear wave test <<<' @@ -111,15 +108,15 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! ! boundaries ! - xmini = 0. - xmaxi = 1.0 + xmini = -0.5 + xmaxi = 0.5 length = xmaxi - xmini deltax = length/npartx ! try to give y boundary that is a multiple of 6 particle spacings in the low density part fac = 6.*(int((1.-epsilon(0.))*radkern/6.) + 1) deltay = fac*deltax*sqrt(0.75) deltaz = fac*deltax*sqrt(6.)/3. - call set_boundary(xmini,xmaxi,xmini,deltay,-deltaz,deltaz) + call set_boundary(xmini,xmaxi,-deltay,deltay,-deltaz,deltaz) ! ! general parameters ! @@ -214,13 +211,6 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, dustfrac(:,i) = 0. endif endif - -! -!--add a little perturbation to fake some noise -! -! xyzh(1,i) = xyzh(1,i) + 0.0001*(ran2(iseed)-0.5) -! xyzh(2,i) = xyzh(2,i) + 0.0001*(ran2(iseed)-0.5) - enddo npartoftype(itype) = npart - npart_previous From 29bd4eba16e4bee7e323998f47263dc8f3c43120 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 17 Oct 2024 15:19:16 +1100 Subject: [PATCH 062/134] (apr) fix typo --- src/setup/relax_star.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/setup/relax_star.f90 b/src/setup/relax_star.f90 index 41d9e450d..fc6e0d23d 100644 --- a/src/setup/relax_star.f90 +++ b/src/setup/relax_star.f90 @@ -188,7 +188,7 @@ subroutine relax_star(nt,rho,pr,r,npart,xyzh,use_var_comp,Xfrac,Yfrac,mu,ierr,np return endif if (id==master) print "(/,3(a,1pg11.3),/,a,1pg11.3,a,i4)",& - ' s-STAR-O-MATIC: Etherm:',etherm,' Epot:',Epot, ' R*:',maxval(r), & + ' RELAX-A-STAR-O-MATIC: Etherm:',etherm,' Epot:',Epot, ' R*:',maxval(r), & ' WILL stop when Ekin/Epot < ',tol_ekin,' OR Iter=',maxits if (write_files) then From bfd930468632849d97d73fc2d2638a844b315183 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 17 Oct 2024 15:25:55 +1100 Subject: [PATCH 063/134] (apr) cleanup calls to read/write inopts --- src/main/apr.f90 | 1 + src/main/readwrite_infile.F90 | 10 +++------- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/src/main/apr.f90 b/src/main/apr.f90 index 0733027f8..bd6574419 100644 --- a/src/main/apr.f90 +++ b/src/main/apr.f90 @@ -595,6 +595,7 @@ subroutine write_options_apr(iunit) use infile_utils, only:write_inopt integer, intent(in) :: iunit + write(iwritein,"(/,a)") '# options for adaptive particle refinement' call write_inopt(apr_max_in,'apr_max','number of additional refinement levels (3 -> 2x resolution)',iunit) call write_inopt(ref_dir,'ref_dir','increase (1) or decrease (-1) resolution',iunit) call write_inopt(apr_type,'apr_type','1: static, 2: moving sink, 3: create clumps',iunit) diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index e0d806c4c..1094e6a6a 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -308,10 +308,8 @@ subroutine write_infile(infile,logfile,evfile,dumpfile,iwritein,iprint) call write_options_gravitationalwaves(iwritein) call write_options_boundary(iwritein) - if (use_apr) then - write(iwritein,"(/,a)") '# options for adaptive particle refinement' - call write_options_apr(iwritein) - endif + if (use_apr) call write_options_apr(iwritein) + call write_options_H2R(iwritein) if (iwritein /= iprint) close(unit=iwritein) @@ -565,9 +563,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) #ifdef INJECT_PARTICLES if (.not.imatch) call read_options_inject(name,valstring,imatch,igotallinject,ierr) #endif - if (use_apr) then - if (.not.imatch) call read_options_apr(name,valstring,imatch,igotallapr,ierr) - endif + if (.not.imatch .and. use_apr) call read_options_apr(name,valstring,imatch,igotallapr,ierr) if (.not.imatch .and. nucleation) call read_options_dust_formation(name,valstring,imatch,igotalldustform,ierr) if (.not.imatch .and. sink_radiation) then call read_options_ptmass_radiation(name,valstring,imatch,igotallprad,ierr) From 1525f7f646703a9de8b012afc623c93499c24e27 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Thu, 17 Oct 2024 11:45:57 +0200 Subject: [PATCH 064/134] (set-binary) update npartoftype array when particle types are set according to a specific star --- src/setup/set_star.f90 | 6 +++++- src/setup/set_star_utils.f90 | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index cea8982c8..b35f62fcf 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -304,6 +304,8 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& do i=npart_old+1,npart call set_particle_type(i,itype+istar_offset) enddo + npartoftype(itype+istar_offset) = npartoftype(itype+istar_offset) + npart - npart_old + npartoftype(igas) = npartoftype(igas) - (npart - npart_old) endif ! ! Print summary to screen @@ -388,7 +390,7 @@ end subroutine set_stars !+ !----------------------------------------------------------------------- subroutine shift_star(npart,xyz,vxyz,x0,v0,itype,corotate) - use part, only:get_particle_type,set_particle_type,igas + use part, only:get_particle_type,set_particle_type,igas,npartoftype use vectorutils, only:cross_product3D integer, intent(in) :: npart real, intent(inout) :: xyz(:,:),vxyz(:,:) @@ -421,6 +423,8 @@ subroutine shift_star(npart,xyz,vxyz,x0,v0,itype,corotate) if (mytype /= itype+istar_offset) cycle over_parts ! reset type back to gas call set_particle_type(i,igas) + npartoftype(itype+istar_offset) = npartoftype(itype+istar_offset) - 1 + npartoftype(igas) = npartoftype(igas) + 1 endif xyz(1:3,i) = xyz(1:3,i) + x0(:) vxyz(1:3,i) = vxyz(1:3,i) + v0(:) diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index 4be4dbe7e..ee9ea803d 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -288,7 +288,7 @@ subroutine set_star_density(lattice,id,master,rmin,Rstar,Mstar,hfact,& ! ! set particle type as gas particles ! - npartoftype(igas) = npart ! npart is number on this thread only + npartoftype(igas) = npartoftype(igas) + npart - npart_old ! npart is number on this thread only do i=npart_old+1,npart_old+npart call set_particle_type(i,igas) enddo From dde46d5a976c64b5bba06d3986c121cebb8cb92d Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Thu, 17 Oct 2024 13:16:20 +0200 Subject: [PATCH 065/134] (set-star) fix sink read options logic --- src/setup/set_star.f90 | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index b35f62fcf..9f77bf8d2 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -802,17 +802,10 @@ subroutine read_options_star(star,need_iso,ieos,polyk,db,nerr,label) select case(star%iprofile) case(imesa) - ! core softening options - call read_inopt(star%isinkcore,'isinkcore'//trim(c),db,errcount=nerr) - - if (star%isinkcore) then - call read_inopt(lcore_lsun,'lcore'//trim(c),db,errcount=nerr,min=0.,err=ierr) - if (ierr==0) star%lcore = lcore_lsun*real(solarl/unit_luminosity) - endif - call read_inopt(star%isoftcore,'isoftcore'//trim(c),db,errcount=nerr,min=0) if (star%isoftcore <= 0) then ! sink particle core without softening + call read_inopt(star%isinkcore,'isinkcore'//trim(c),db,errcount=nerr) if (star%isinkcore) then call read_inopt(mcore_msun,'mcore'//trim(c),db,errcount=nerr,min=0.,err=ierr) if (ierr==0) star%mcore = mcore_msun*real(solarm/umass) @@ -820,6 +813,7 @@ subroutine read_options_star(star,need_iso,ieos,polyk,db,nerr,label) if (ierr==0) star%hsoft = hsoft_rsun*real(solarr/udist) endif else + star%isinkcore = .true. call read_inopt(star%outputfilename,'outputfilename'//trim(c),db,errcount=nerr) if (star%isoftcore==2) then star%isofteningopt=3 @@ -837,6 +831,11 @@ subroutine read_options_star(star,need_iso,ieos,polyk,db,nerr,label) if (ierr==0) star%mcore = mcore_msun*real(solarm/umass) endif endif + + if (star%isinkcore) then + call read_inopt(lcore_lsun,'lcore'//trim(c),db,errcount=nerr,min=0.,err=ierr) + if (ierr==0) star%lcore = lcore_lsun*real(solarl/unit_luminosity) + endif case(ievrard) call read_inopt(star%ui_coef,'ui_coef'//trim(c),db,errcount=nerr,min=0.) case(:0) From 9e14e04cad1d1ab6af6db34c189fc68bd4a5b0a1 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Thu, 17 Oct 2024 15:44:00 +0100 Subject: [PATCH 066/134] Fixes for Github tests --- build/Makefile_setups | 10 - src/main/eos_stamatellos.f90 | 20 +- src/setup/setup_sphere.f90 | 848 ----------------------------------- 3 files changed, 11 insertions(+), 867 deletions(-) delete mode 100644 src/setup/setup_sphere.f90 diff --git a/build/Makefile_setups b/build/Makefile_setups index d5f05236e..3a0897eca 100644 --- a/build/Makefile_setups +++ b/build/Makefile_setups @@ -431,16 +431,6 @@ ifeq ($(SETUP), sphereinbox) KNOWN_SETUP=yes endif -ifeq ($(SETUP), sphere) -# sphere setup - ISOTHERMAL=no - PERIODIC=no - IND_TIMESTEPS=yes - GRAVITY=yes - SETUPFILE= velfield_fromcubes.f90 setup_sphere.f90 - KNOWN_SETUP=yes -endif - ifeq ($(SETUP), shock) # shock tube tests PERIODIC=yes diff --git a/src/main/eos_stamatellos.f90 b/src/main/eos_stamatellos.f90 index 5877dcf64..df4239ba4 100644 --- a/src/main/eos_stamatellos.f90 +++ b/src/main/eos_stamatellos.f90 @@ -33,16 +33,18 @@ module eos_stamatellos subroutine init_S07cool() use part, only:npart,maxradprop + use allocutils, only:allocate_array + print *, "Allocating cooling arrays" - allocate(gradP_cool(npart)) - allocate(Gpot_cool(npart)) - allocate(duFLD(npart)) - allocate(lambda_fld(npart)) - allocate(urad_FLD(npart)) - allocate(ttherm_store(npart)) - allocate(teqi_store(npart)) - allocate(opac_store(npart)) - allocate(duSPH(npart)) + call allocate_array('gradP_cool',gradP_cool,npart) + call allocate_array('Gpot_cool',Gpot_cool,npart) + call allocate_array('duFLD',duFLD,npart) + call allocate_array('lambda_fld',lambda_fld,npart) + call allocate_array('urad_FLD',urad_FLD,npart) + call allocate_array('ttherm_store',ttherm_store,npart) + call allocate_array('teqi_store',teqi_store,npart) + call allocate_array('opac_store',opac_store,npart) + call allocate_array('duSPH',duSPH,npart) Gpot_cool(:) = 0d0 gradP_cool(:) = 0d0 urad_FLD(:) = 0d0 diff --git a/src/setup/setup_sphere.f90 b/src/setup/setup_sphere.f90 deleted file mode 100644 index c297a13b5..000000000 --- a/src/setup/setup_sphere.f90 +++ /dev/null @@ -1,848 +0,0 @@ -!--------------------------------------------------------------------------! -! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! -! Copyright (c) 2007-2023 The Authors (see AUTHORS) ! -! See LICENCE file for usage and distribution conditions ! -! http://phantomsph.bitbucket.io/ ! -!--------------------------------------------------------------------------! -module setup -! -! This module sets up a sphere-in-a-box: a cold, dense sphere placed in -! a warm medium; the two media are in pressure-equilibrium. -! This currently works for gas-only and two-fluid dust. -! -! :References: None -! -! :Owner: Alison Young -! -! :Runtime parameters: -! - BEfac : *over-density factor of the BE sphere [code units]* -! - BEmass : *mass radius of the BE sphere [code units]* -! - BErad_norm : *normalised radius of the BE sphere* -! - BErad_phys : *physical radius of the BE sphere [code units]* -! - BErho_cen : *central density of the BE sphere [code units]* -! - Bzero : *Magnetic field strength in Gauss* -! - T_sphere : *temperature in sphere* -! - ang_Bomega : *Angle (degrees) between B and rotation axis* -! - angvel : *angular velocity in rad/s* -! - beta_r : *rotational-to-gravitational energy ratio* -! - density_contrast : *density contrast in code units* -! - dist_unit : *distance unit (e.g. au)* -! - dust_to_gas_ratio : *dust-to-gas ratio* -! - form_binary : *the intent is to form a central binary* -! - graindenscgs : *grain density [g/cm^3]* -! - grainsizecgs : *grain size in [cm]* -! - h_acc : *accretion radius (code units)* -! - h_soft_sinksink : *sink-sink softening radius (code units)* -! - iBE_options : *The set of parameters to define the BE sphere* -! - icreate_sinks : *1: create sinks. 0: do not create sinks* -! - lattice : *particle lattice (random,cubic,closepacked,hcp,hexagonal)* -! - lbox : *length of a box side in terms of spherical radii* -! - mass_unit : *mass unit (e.g. solarm)* -! - masstoflux : *mass-to-magnetic flux ratio in units of critical value* -! - ndusttypes : *number of grain sizes* -! - np : *requested number of particles in sphere* -! - r_crit : *critical radius (code units)* -! - r_sphere : *radius of sphere in code units* -! - rho_final : *final maximum density (<=0 to ignore) (cgs units)* -! - rho_pert_amp : *amplitude of density perturbation* -! - rms_mach : *turbulent rms mach number* -! - shuffle_parts : *relax particles by shuffling* -! - sindex : *power-law index, e.g. MRN* -! - smaxcgs : *maximum grain size [cm]* -! - smincgs : *minimum grain size [cm]* -! - totmass_sphere : *mass of sphere in code units* -! - use_BE_sphere : *centrally condense as a BE sphere* -! -! :Dependencies: boundary, centreofmass, datafiles, dim, dust, eos, -! eos_stamatellos, infile_utils, io, kernel, mpidomain, options, part, -! physcon, prompting, ptmass, set_dust, set_dust_options, setup_params, -! spherical, timestep, unifdis, units, utils_shuffleparticles, velfield -! - use part, only:mhd,graindens,grainsize,ndusttypes,ndustsmall - use dim, only:use_dust,maxvxyzu,periodic,maxdustsmall - use options, only:calc_erot - use dust, only:grainsizecgs,graindenscgs - use set_dust_options, only:grainsizeinp,graindensinp,igrainsize,igraindens,& - smincgs,smaxcgs,sindex,dustbinfrac - implicit none - - public :: setpart - - private - !--private module variables - real :: xmini(3), xmaxi(3) - real :: density_contrast,totmass_sphere,r_sphere,T_sphere,cs_sphere - real :: angvel,beta_r,Bzero_G,masstoflux,dtg,ang_Bomega,rms_mach - real :: rho_pert_amp,lbox - real :: BErho_cen,BErad_phys,BErad_norm,BEmass,BEfac - real :: r_crit_setup,h_acc_setup,h_soft_sinksink_setup,rhofinal_setup - real(kind=8) :: udist,umass - integer :: np,iBEparam,icreate_sinks_setup - logical :: BEsphere,binary,mu_not_B,cs_in_code,angvel_not_betar,shuffle_parts - logical :: is_cube = .true. ! if false, then can set a rectangle if BEsphere=false; for backwards compatibility - character(len=20) :: dist_unit,mass_unit,lattice - character(len= 1), parameter :: labelx(3) = (/'x','y','z'/) - -contains - -!---------------------------------------------------------------- -!+ -! setup for a sphere-in-a-box -!+ -!---------------------------------------------------------------- -subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact_out,time,fileprefix) - use physcon, only:pi,solarm,hours,years,au,kboltz,kb_on_mh - use dim, only:maxdusttypes,use_dustgrowth,maxdustlarge - use setup_params, only:rhozero,npart_total,rmax,ihavesetupB - use io, only:master,fatal,iprint - use unifdis, only:set_unifdis - use spherical, only:set_sphere - use boundary, only:set_boundary,xmin,xmax,ymin,ymax,zmin,zmax,dxbound,dybound,dzbound - use prompting, only:prompt - use units, only:set_units,select_unit,utime,unit_density,unit_Bfield,unit_velocity,unit_ergg - use eos, only:polyk2,ieos,gmw - use eos_stamatellos, only:read_optab,getopac_opdep,optable,getintenerg_opdep,eos_file - use part, only:Bxyz,Bextx,Bexty,Bextz,igas,idust,set_particle_type,hfact,dustfrac - use set_dust_options, only:dustbinfrac,set_dust_default_options,set_dust_interactively,dust_method - use dust, only:ilimitdustflux - use timestep, only:dtmax,tmax,dtmax_dratio,dtmax_min - use centreofmass, only:reset_centreofmass - use options, only:nfulldump,rhofinal_cgs,hdivbbmax_max,use_dustfrac - use kernel, only:hfact_default - use mpidomain, only:i_belong - use ptmass, only:icreate_sinks,r_crit,h_acc,h_soft_sinksink - use velfield, only:set_velfield_from_cubes - use datafiles, only:find_phantom_datafile - use set_dust, only:set_dustfrac,set_dustbinfrac - use utils_shuffleparticles, only:shuffleparticles - integer, intent(in) :: id - integer, intent(inout) :: npart - integer, intent(out) :: npartoftype(:) - real, intent(out) :: xyzh(:,:) - real, intent(out) :: vxyzu(:,:) - real, intent(out) :: massoftype(:) - real, intent(out) :: polyk,gamma,hfact_out - real, intent(inout) :: time - character(len=20), intent(in) :: fileprefix - character(len=20), parameter :: filevx = 'cube_v1.dat' - character(len=20), parameter :: filevy = 'cube_v2.dat' - character(len=20), parameter :: filevz = 'cube_v3.dat' - real(kind=8) :: h_acc_in - integer :: i,np_in,npartsphere,npmax,iBElast,ierr - integer :: iBE,ilattice - real :: totmass,vol_box,psep,psep_box,pmass_dusttogas - real :: vol_sphere,dens_sphere,dens_medium,cs_medium,angvel_code,przero - real :: u_sphere,kappaBar,kappaPart,gmwi,gammai,cs_sphere_cgs - real :: t_ff,r2,area,Bzero,rmasstoflux_crit - real :: rxy2,rxyz2,phi,dphi,central_density,edge_density,rmsmach,v2i,turbfac,rhocritTcgs,ui - real, allocatable :: rtab(:),rhotab(:) - logical :: iexist - logical :: make_sinks = .true. ! the default prompt is to ask to make sinks - character(len=120) :: filex,filey,filez - character(len=100) :: filename,cwd - character(len=40) :: fmt - character(len=10) :: h_acc_char - logical :: usebox = .false. - !--Initialise dust distribution, if using dust - if (use_dust) call set_dust_default_options() - - filename = trim(fileprefix)//'.setup' - print "(/,1x,63('-'),1(/,a),/,1x,63('-'),/)",& - ' Sphere setup' - - inquire(file=filename,exist=iexist) - if (iexist) then - call read_setupfile(filename,ierr) - np_in = np - if (ierr /= 0) then - if (id==master) call write_setupfile(filename) - stop - endif - elseif (id==master) then - print "(a,/)",trim(filename)//' not found: using interactive setup' - dist_unit = '1.0d16cm' - mass_unit = 'solarm' - ierr = 1 - do while (ierr /= 0) - call prompt('Enter mass unit (e.g. solarm,jupiterm,earthm)',mass_unit) - call select_unit(mass_unit,umass,ierr) - if (ierr /= 0) print "(a)",' ERROR: mass unit not recognised' - enddo - ierr = 1 - do while (ierr /= 0) - call prompt('Enter distance unit (e.g. au,pc,kpc,0.1pc)',dist_unit) - call select_unit(dist_unit,udist,ierr) - if (ierr /= 0) print "(a)",' ERROR: length unit not recognised' - enddo - ! - ! units - ! - call set_units(dist=udist,mass=umass,G=1.d0) - ! - ! prompt user for settings - ! - npmax = int(2.0/3.0*size(xyzh(1,:))) ! approx max number allowed in sphere given size(xyzh(1,:)) - if (npmax < 300000) then - np = npmax - elseif (npmax < 1000000) then - np = 300000 - else - np = 1000000 - endif - call prompt('Enter the approximate number of particles in the sphere',np,0,npmax) - np_in = np - - lattice = 'closepacked' - ilattice = 3 - call prompt('Enter the type of particle lattice (1=random,2=cubic,3=closepacked,4=hexagonal)',ilattice,0,4) - if (ilattice==1) then - lattice = 'random' - shuffle_parts = .false. - elseif (ilattice==2) then - lattice = 'cubic' - elseif (ilattice==4) then - lattice = 'hexagonal' - endif - - shuffle_parts = .false. - if (ilattice==1) shuffle_parts = .true. - call prompt('Relax particles by shuffling?',shuffle_parts) - - BEsphere = .false. - call prompt('Centrally condense the sphere as a BE sphere?',BEsphere) - - if (.not. BEsphere) then - r_sphere = 4. - call prompt('Enter radius of sphere in units of '//dist_unit,r_sphere,0.) - lbox = 4. - call prompt('Enter the box size in units of spherical radii: ',lbox,1.) - if (.not. is_cube) then - do i=1,3 - xmini(i) = -0.5*(lbox*r_sphere) - xmaxi(i) = -xmini(i) - enddo - endif - - totmass_sphere = 1.0 - call prompt('Enter total mass in sphere in units of '//mass_unit,totmass_sphere,0.) - else - print *, 'deleted' - endif - - call prompt('Enter temperature in sphere',T_sphere,1.,100.) - - call prompt('Enter EOS filename',eos_file) - - if (binary) then - angvel = 1.006d-12 - else - angvel = 1.77d-13 - endif - angvel_not_betar = .true. - beta_r = 0.02 - call prompt('Input angular velocity (true); else input ratio of rotational-to-potential energy ',angvel_not_betar) - if (angvel_not_betar) then - call prompt('Enter angular rotation speed in rad/s ',angvel,0.) - else - call prompt('Enter ratio of rotational-to-potential energy ',beta_r,0.) - endif - - rms_mach = 0. - call prompt('Enter the Mach number of the cloud turbulence',rms_mach,0.) - - if (mhd) then - Bzero_G = 1.0d-4 ! G - masstoflux = 5.0 - ang_Bomega = 180.0 - mu_not_B = .true. - call prompt('Input the mass-to-flux ratio (true); else input the magnetic field strength ',mu_not_B) - if (mu_not_B) then - call prompt('Enter mass-to-flux ratio in units of critical value ',masstoflux,0.) - else - call prompt('Enter magnetic field strength in Gauss ',Bzero_G,0.) - endif - call prompt('Enter the angle (degrees) between B and the rotation axis? ',ang_Bomega) - endif - - if (use_dust) then - !--currently assume one fluid dust - dtg = 0.01 - grainsize = 0. - graindens = 0. - grainsizecgs = 0.1 - graindenscgs = 3. - ndustsmall = 1 - smincgs = 1.e-5 - smaxcgs = 1. - sindex = 3.5 - call prompt('Enter total dust to gas ratio',dtg,0.) - call prompt('How many grain sizes do you want?',ndustsmall,1,maxdustsmall) - ndusttypes = ndustsmall - if (ndusttypes > 1) then - !--grainsizes - call prompt('Enter minimum grain size in cm',smincgs,0.) - call prompt('Enter maximum grain size in cm',smaxcgs,0.) - !--mass distribution - call prompt('Enter power-law index, e.g. MRN',sindex) - !--grain density - call prompt('Enter grain density in g/cm^3',graindenscgs,0.) - else - call prompt('Enter grain size in cm',grainsizecgs,0.) - call prompt('Enter grain density in g/cm^3',graindenscgs,0.) - endif - endif - - if (binary) then - rho_pert_amp = 0.1 - call prompt('Enter the amplitute of the density perturbation ',rho_pert_amp,0.0,0.4) - endif - - ! ask about sink particle details; these will not be saved to the .setup file since they exist in the .in file - ! - call prompt('Do you wish to dynamically create sink particles? ',make_sinks) - if (make_sinks) then - if (binary) then - h_acc_char = '3.35au' - else - h_acc_char = '1.0d-2' - endif - call prompt('Enter the accretion radius of the sink (with units; e.g. au,pc,kpc,0.1pc) ',h_acc_char) - call select_unit(h_acc_char,h_acc_in,ierr) - h_acc_setup = h_acc_in - if (ierr==0 ) h_acc_setup = h_acc_setup/udist - r_crit_setup = 5.0*h_acc_setup - icreate_sinks_setup = 1 - if (binary) h_soft_sinksink_setup = 0.4*h_acc_setup - else - icreate_sinks_setup = 0 - rhofinal_setup = 0.15 - call prompt('Enter final maximum density in g/cm^3 (ignored for <= 0) ',rhofinal_setup) - endif - if (id==master) call write_setupfile(filename) - stop 'please edit .setup file and rerun phantomsetup' - else - stop ! MPI, stop on other threads, interactive on master - endif - ! - ! units - ! - call set_units(dist=udist,mass=umass,G=1.d0) - ! - ! set dust properties - ! - if (use_dust) then - use_dustfrac = .true. - ndustsmall = ndusttypes - if (ndusttypes > 1) then - call set_dustbinfrac(smincgs,smaxcgs,sindex,dustbinfrac(1:ndusttypes),grainsize(1:ndusttypes)) - grainsize(1:ndusttypes) = grainsize(1:ndusttypes)/udist - graindens(1:ndusttypes) = graindenscgs/umass*udist**3 - else - grainsize(1) = grainsizecgs/udist - graindens(1) = graindenscgs/umass*udist**3 - endif - endif - - - - ! general parameters - ! - - vol_sphere = 4./3.*pi*r_sphere**3 - rhozero = totmass_sphere / vol_sphere - dens_sphere = rhozero - - ! call EOS - ieos = 21 - ierr = 0 - call read_optab(eos_file,ierr) - call getintenerg_opdep(T_sphere, dens_sphere*unit_density, u_sphere) - call getopac_opdep(u_sphere,dens_sphere,kappaBar,kappaPart,T_sphere,gmwi) - u_sphere = u_sphere/unit_ergg - time = 0. - if (use_dust) dust_method = 1 - hfact = hfact_default - hfact_out = hfact_default - print *, 'gamma =', gamma, 'u_sphere = ',u_sphere,T_sphere - - rmax = r_sphere - if (angvel_not_betar) then - angvel_code = angvel*utime - else - angvel_code = sqrt(3.0*totmass_sphere*beta_r/r_sphere**3) - angvel = angvel_code/utime - endif - - - totmass = totmass_sphere - t_ff = sqrt(3.*pi/(32.*dens_sphere)) - - przero = dens_sphere * kb_on_mh * T_sphere/gmwi ! code units - gammai = 1.d0 + (przero/u_sphere/dens_sphere) - cs_sphere = sqrt(gammai * przero/dens_sphere) - cs_sphere_cgs = cs_sphere * unit_velocity - polyk = cs_sphere**2 - gamma = 5./3. ! not used but set to keep Phantom happy. - ! - ! setup particles in the sphere; use this routine to get N_sphere as close to np as possible - ! - if (BEsphere) then - call set_sphere(trim(lattice),id,master,0.,r_sphere,psep,hfact,npart,xyzh, & - rhotab=rhotab(1:iBElast),rtab=rtab(1:iBElast),nptot=npart_total,& - exactN=.true.,np_requested=np,mask=i_belong) - else - call set_sphere(trim(lattice),id,master,0.,r_sphere,psep,hfact,npart,xyzh,nptot=npart_total,& - exactN=.true.,np_requested=np,mask=i_belong) - if (trim(lattice)/='random') print "(a,es10.3)",' Particle separation in sphere = ',psep - endif - print "(a)",' Initialised sphere' - npartsphere = npart_total - - ! - ! set particle properties - ! - npartoftype(:) = 0 - npartoftype(igas) = npart - dustfrac = 0. - if (massoftype(igas) < epsilon(massoftype(igas))) massoftype(igas) = totmass/npart_total - do i = 1,npartoftype(igas) - call set_particle_type(i,igas) - if (use_dust .and. dust_method==1) then - if (ndusttypes > 1) then - dustfrac(1:ndusttypes,i) = dustbinfrac(1:ndusttypes)*dtg - else - dustfrac(1,i) = dtg/(1.+dtg) ! call set_dustfrac(dtg,dustfrac(:,i)) - endif - endif - enddo - ! - ! Set two-fluid dust - ! (currently deactivated; will need to re-test before use to ensure it is fully compatible with the current dust algorithms) - ! - if (use_dust .and. dust_method==2) then - ! particle separation in dust sphere & sdjust for close-packed lattice - pmass_dusttogas = 10.*dtg*massoftype(igas) - psep = (vol_sphere/pmass_dusttogas/real(np))**(1./3.) - psep = psep*sqrt(2.)**(1./3.) - call set_sphere(trim(lattice),id,master,0.,r_sphere,psep,hfact,npart,xyzh,nptot=npart_total,& - exactN=.true.,np_requested=np/10,mask=i_belong) - npartoftype(idust) = int(npart_total) - npartoftype(igas) - massoftype(idust) = totmass_sphere*dtg/npartoftype(idust) - - do i = npartoftype(igas)+1,npart - call set_particle_type(i,idust) - enddo - - print "(a,4(i10,1x))", ' particle numbers: (gas_total, gas_sphere, dust, total): ' & - , npartoftype(igas),npartsphere,npartoftype(idust),npart - print "(a,2es10.3)" , ' particle masses: (gas,dust): ',massoftype(igas),massoftype(idust) - else - print "(a,3(i10,1x))", ' particle numbers: (sphere, low-density medium, total): ' & - , npartsphere, npart-npartsphere,npart - print "(a,es10.3)",' particle mass = ',massoftype(igas) - endif - ! - ! shuffle particles - ! - if (shuffle_parts) then - print*, "lets shuffle!" - if (BEsphere) then - call shuffleparticles(iprint,npart,xyzh,massoftype(igas),dmedium=dens_medium,ntab=iBElast, & - rtab=rtab,dtab=rhotab,dcontrast=density_contrast,is_setup=.true.,prefix=trim(fileprefix)) - else - call shuffleparticles(iprint,npart,xyzh,massoftype(igas), & - rsphere=rmax,dsphere=dens_sphere,dmedium=dens_medium,is_setup=.true.,prefix=trim(fileprefix)) - endif - endif - if (BEsphere) deallocate(rtab,rhotab) - ! - ! reset to centre of mass - ! (if random or shuffling, recentering may shift particles outside of the defined range) - ! - if (trim(lattice)/='random' .and. .not.shuffle_parts) call reset_centreofmass(npart,xyzh,vxyzu) - - ! - !--Stretching the spatial distribution to perturb the density profile, if requested - ! - if (binary) then - do i = 1,npart - rxy2 = xyzh(1,i)*xyzh(1,i) + xyzh(2,i)*xyzh(2,i) - rxyz2 = rxy2 + xyzh(3,i)*xyzh(3,i) - if (rxyz2 <= r_sphere**2) then - phi = atan(xyzh(2,i)/xyzh(1,i)) - if (xyzh(1,i) < 0.0) phi = phi + pi - dphi = 0.5*rho_pert_amp*sin(2.0*phi) - phi = phi - dphi - xyzh(1,i) = sqrt(rxy2)*cos(phi) - xyzh(2,i) = sqrt(rxy2)*sin(phi) - endif - enddo - endif - ! - ! Velocity: Turbulent velocity field - ! - vxyzu = 0. - if (rms_mach > 0.) then - call getcwd(cwd) - ! personal hack for J. Wurster since different computer clusters required different velocity fields - if (index(cwd,'gpfs1/scratch/astro/jhw5') > 0 .or. index(cwd,'data/dp187/dc-wurs1') > 0 ) then - ! Kennedy or Dial - filex = find_phantom_datafile(filevx,'velfield_sphng') - filey = find_phantom_datafile(filevy,'velfield_sphng') - filez = find_phantom_datafile(filevz,'velfield_sphng') - else - filex = find_phantom_datafile(filevx,'velfield') - filey = find_phantom_datafile(filevy,'velfield') - filez = find_phantom_datafile(filevz,'velfield') - endif - - call set_velfield_from_cubes(xyzh(:,1:npartsphere),vxyzu(:,:npartsphere),npartsphere, & - filex,filey,filez,1.,r_sphere,.false.,ierr) - if (ierr /= 0) call fatal('setup','error setting up velocity field on clouds') - - rmsmach = 0.0 - print*, 'Turbulence being set by user' - do i = 1,npartsphere - v2i = dot_product(vxyzu(1:3,i),vxyzu(1:3,i)) - rmsmach = rmsmach + v2i/cs_sphere**2 - enddo - rmsmach = sqrt(rmsmach/npartsphere) - if (rmsmach > 0.) then - turbfac = rms_mach/rmsmach ! normalise the energy to the desired mach number - else - turbfac = 0. - endif - do i = 1,npartsphere - vxyzu(1:3,i) = turbfac*vxyzu(1:3,i) - enddo - endif - ! - ! Velocity: uniform rotation (thermal energy & magnetic field too) - ! - do i=1,npart - r2 = dot_product(xyzh(1:3,i),xyzh(1:3,i)) - if (r2 < r_sphere**2) then - vxyzu(1,i) = vxyzu(1,i) - angvel_code*xyzh(2,i) - vxyzu(2,i) = vxyzu(2,i) + angvel_code*xyzh(1,i) - ui = u_sphere - if (maxvxyzu >= 4) vxyzu(4,i) = ui - else - if (maxvxyzu >= 4) vxyzu(4,i) = 1.5*polyk2 - endif - enddo - ! - ! set default runtime parameters if .in file does not exist - ! - filename=trim(fileprefix)//'.in' - inquire(file=filename,exist=iexist) - dtmax = t_ff/100. ! Since this variable can change, always reset it if running phantomsetup - if (.not. iexist) then - if (binary) then - tmax = 1.50*t_ff ! = 13.33 for default settings (Wurster, Price & Bate 2017) - else - tmax = 1.21*t_ff ! = 10.75 for default settings (Wurster, Price & Bate 2016) - endif - ieos = 21 - nfulldump = 1 - calc_erot = .true. - dtmax_dratio = 1.258 - icreate_sinks = icreate_sinks_setup - r_crit = r_crit_setup - h_acc = h_acc_setup - if (binary) h_soft_sinksink = h_soft_sinksink_setup - hdivbbmax_max = 1.0 ! 512. - if (icreate_sinks==1) then - dtmax_min = dtmax/8.0 - else - dtmax_min = 0.0 - rhofinal_cgs = rhofinal_setup - endif - ilimitdustflux = .true. - endif - ! - !--Summarise the sphere - ! - print "(a,i10)",' Input npart_sphere = ',np - print "(1x,50('-'))" - print "(a)",' Quantity (code units) (physical units)' - print "(1x,50('-'))" - fmt = "((a,1pg10.3,3x,1pg10.3),a)" - print fmt,' Total mass : ',totmass,totmass*umass,' g' - print fmt,' Mass in sphere : ',totmass_sphere,totmass_sphere*umass,' g' - print fmt,' Radius of sphere : ',r_sphere,r_sphere*udist,' cm' - if (BEsphere) then - print fmt,' Mean rho sphere : ',dens_sphere,dens_sphere*unit_density,' g/cm^3' - print fmt,' central density : ',central_density,central_density*unit_density,' g/cm^3' - print fmt,' edge density : ',edge_density,edge_density*unit_density,' g/cm^3' - print fmt,' Mean rho medium : ',dens_medium,dens_medium*unit_density,' g/cm^3' - else - print fmt,' Density sphere : ',dens_sphere,dens_sphere*unit_density,' g/cm^3' - endif - print fmt,' cs in sphere : ',cs_sphere,cs_sphere_cgs,' cm/s' - print fmt,' Free fall time : ',t_ff,t_ff*utime/years,' yrs' - print fmt,' Angular velocity : ',angvel_code,angvel,' rad/s' - print fmt,' Turbulent Mach no: ',rms_mach - print fmt,' Omega*t_ff : ',angvel_code*t_ff - - if (use_dust) then - print fmt,' dust-to-gas ratio: ',dtg,dtg,' ' - endif - print "(1x,50('-'))" - -end subroutine setpart - -!---------------------------------------------------------------- -!+ -! write parameters to setup file -!+ -!---------------------------------------------------------------- -subroutine write_setupfile(filename) - use infile_utils, only: write_inopt - character(len=*), intent(in) :: filename - integer, parameter :: iunit = 20 - integer :: i - - print "(a)",' writing setup options file '//trim(filename) - open(unit=iunit,file=filename,status='replace',form='formatted') - write(iunit,"(a)") '# input file for sphere-in-box setup routines' - write(iunit,"(/,a)") '# units' - call write_inopt(dist_unit,'dist_unit','distance unit (e.g. au)',iunit) - call write_inopt(mass_unit,'mass_unit','mass unit (e.g. solarm)',iunit) - - write(iunit,"(/,a)") '# particle resolution & placement' - call write_inopt(np,'np','requested number of particles in sphere',iunit) - call write_inopt(lattice,'lattice','particle lattice (random,cubic,closepacked,hcp,hexagonal)',iunit) - call write_inopt(shuffle_parts,'shuffle_parts','relax particles by shuffling',iunit) - - write(iunit,"(/,a)") '# options for box' - if (.not.BEsphere .and. .not.is_cube) then - ! left here for backwards compatibility and for simplicity if the user requires a rectangle in the future - do i=1,3 - call write_inopt(xmini(i),labelx(i)//'min',labelx(i)//' min',iunit) - call write_inopt(xmaxi(i),labelx(i)//'max',labelx(i)//' max',iunit) - enddo - else - call write_inopt(lbox,'lbox','length of a box side in terms of spherical radii',iunit) - endif - - write(iunit,"(/,a)") '# intended result' - call write_inopt(binary,'form_binary','the intent is to form a central binary',iunit) - - write(iunit,"(/,a)") '# options for sphere' - call write_inopt(BEsphere,'use_BE_sphere','centrally condense as a BE sphere',iunit) - if (.not. BEsphere) then - call write_inopt(r_sphere,'r_sphere','radius of sphere in code units',iunit) - call write_inopt(totmass_sphere,'totmass_sphere','mass of sphere in code units',iunit) - else - call write_inopt(iBEparam,'iBE_options','The set of parameters to define the BE sphere',iunit) - if (iBEparam==1 .or. iBEparam==2 .or. iBEparam==3) & - call write_inopt(BErho_cen,'BErho_cen','central density of the BE sphere [code units]',iunit) - if (iBEparam==1 .or. iBEparam==4 .or. iBEparam==6) & - call write_inopt(BErad_phys,'BErad_phys','physical radius of the BE sphere [code units]',iunit) - if (iBEparam==2 .or. iBEparam==4 .or. iBEparam==5) & - call write_inopt(BErad_norm,'BErad_norm','normalised radius of the BE sphere',iunit) - if (iBEparam==3 .or. iBEparam==5 .or. iBEparam==6) & - call write_inopt(BEmass,'BEmass','mass radius of the BE sphere [code units]',iunit) - if (iBEparam==4 .or. iBEparam==5) & - call write_inopt(BEfac,'BEfac','over-density factor of the BE sphere [code units]',iunit) - endif - call write_inopt(density_contrast,'density_contrast','density contrast in code units',iunit) - call write_inopt(T_sphere,'T_sphere','temperature in sphere',iunit) - if (angvel_not_betar) then - call write_inopt(angvel,'angvel','angular velocity in rad/s',iunit) - else - call write_inopt(beta_r,'beta_r','rotational-to-gravitational energy ratio',iunit) - endif - call write_inopt(rms_mach,'rms_mach','turbulent rms mach number',iunit) - if (mhd) then - if (mu_not_B) then - call write_inopt(masstoflux,'masstoflux','mass-to-magnetic flux ratio in units of critical value',iunit) - else - call write_inopt(Bzero_G,'Bzero','Magnetic field strength in Gauss',iunit) - endif - call write_inopt(ang_Bomega,'ang_Bomega','Angle (degrees) between B and rotation axis',iunit) - endif - if (use_dust) then - write(iunit,"(/,a)") '# Dust properties' - call write_inopt(dtg,'dust_to_gas_ratio','dust-to-gas ratio',iunit) - call write_inopt(ndusttypes,'ndusttypes','number of grain sizes',iunit) - if (ndusttypes > 1) then - call write_inopt(smincgs,'smincgs','minimum grain size [cm]',iunit) - call write_inopt(smaxcgs,'smaxcgs','maximum grain size [cm]',iunit) - call write_inopt(sindex, 'sindex', 'power-law index, e.g. MRN',iunit) - call write_inopt(graindenscgs,'graindenscgs','grain density [g/cm^3]',iunit) - else - call write_inopt(grainsizecgs,'grainsizecgs','grain size in [cm]',iunit) - call write_inopt(graindenscgs,'graindenscgs','grain density [g/cm^3]',iunit) - endif - endif - if (binary) then - call write_inopt(rho_pert_amp,'rho_pert_amp','amplitude of density perturbation',iunit) - endif - write(iunit,"(/,a)") '# Sink properties (values in .in file, if present, will take precedence)' - call write_inopt(icreate_sinks_setup,'icreate_sinks','1: create sinks. 0: do not create sinks',iunit) - if (icreate_sinks_setup==1) then - call write_inopt(h_acc_setup,'h_acc','accretion radius (code units)',iunit) - call write_inopt(r_crit_setup,'r_crit','critical radius (code units)',iunit) - if (binary) then - call write_inopt(h_soft_sinksink_setup,'h_soft_sinksink','sink-sink softening radius (code units)',iunit) - endif - else - call write_inopt(rhofinal_setup,'rho_final','final maximum density (<=0 to ignore) (cgs units)',iunit) - endif - close(iunit) - -end subroutine write_setupfile - -!---------------------------------------------------------------- -!+ -! Read parameters from setup file -!+ -!---------------------------------------------------------------- -subroutine read_setupfile(filename,ierr) - use infile_utils, only: open_db_from_file,inopts,read_inopt,close_db - use unifdis, only: is_valid_lattice - use io, only: error - use units, only: select_unit - character(len=*), intent(in) :: filename - integer, intent(out) :: ierr - integer, parameter :: iunit = 21 - integer :: i,nerr,kerr,jerr - type(inopts), allocatable :: db(:) - - !--Read values - print "(a)",' reading setup options from '//trim(filename) - call open_db_from_file(db,filename,iunit,ierr) - call read_inopt(mass_unit,'mass_unit',db,ierr) - call read_inopt(dist_unit,'dist_unit',db,ierr) - call read_inopt(BEsphere,'use_BE_sphere',db,ierr) - call read_inopt(binary,'form_binary',db,ierr) - call read_inopt(np,'np',db,ierr) - call read_inopt(lattice,'lattice',db,ierr) - if (ierr/=0 .or. .not. is_valid_lattice(trim(lattice))) then - print*, ' invalid lattice. Setting to closepacked' - lattice = 'closepacked' - endif - call read_inopt(shuffle_parts,'shuffle_parts',db,ierr) - - call read_inopt(lbox,'lbox',db,jerr) ! for backwards compatibility - if (jerr /= 0) then - do i=1,3 - call read_inopt(xmini(i),labelx(i)//'min',db,ierr) - call read_inopt(xmaxi(i),labelx(i)//'max',db,ierr) - enddo - lbox = -2.0*xmini(1)/r_sphere - endif - - if (.not. BEsphere) then - call read_inopt(r_sphere,'r_sphere',db,ierr) - call read_inopt(totmass_sphere,'totmass_sphere',db,ierr) - else - call read_inopt(iBEparam,'iBE_options',db,ierr) - if (iBEparam==1 .or. iBEparam==2 .or. iBEparam==3) call read_inopt(BErho_cen,'BErho_cen',db,ierr) - if (iBEparam==1 .or. iBEparam==4 .or. iBEparam==6) call read_inopt(BErad_phys,'BErad_phys',db,ierr) - if (iBEparam==2 .or. iBEparam==4 .or. iBEparam==5) call read_inopt(BErad_norm,'BErad_norm',db,ierr) - if (iBEparam==3 .or. iBEparam==5 .or. iBEparam==6) call read_inopt(BEmass,'BEmass',db,ierr) - if (iBEparam==4 .or. iBEparam==5) call read_inopt(BEfac,'BEfac',db,ierr) - endif - - call read_inopt(T_sphere,'T_sphere',db,jerr) - cs_in_code = .false. ! for backwards compatibility - if (jerr /= 0 .and. kerr == 0) then - cs_in_code = .false. - elseif (jerr == 0 .and. kerr /= 0) then - cs_in_code = .true. - else - ierr = ierr + 1 - endif - call read_inopt(angvel,'angvel',db,jerr) - call read_inopt(beta_r,'beta_r',db,kerr) - angvel_not_betar = .true. - if (jerr /= 0 .and. kerr == 0) then - angvel_not_betar = .false. - elseif (jerr == 0 .and. kerr /= 0) then - angvel_not_betar = .true. - else - ierr = ierr + 1 - endif - call read_inopt(rms_mach,'rms_mach',db,ierr) - mu_not_B = .true. - if (mhd) then - call read_inopt(masstoflux,'masstoflux',db,jerr) - call read_inopt(Bzero_G, 'Bzero', db,kerr) - call read_inopt(ang_Bomega,'ang_Bomega',db,ierr) - if (jerr /= 0 .and. kerr == 0) then - mu_not_B = .false. - elseif (jerr == 0 .and. kerr /= 0) then - mu_not_B = .true. - else - ierr = ierr + 1 - endif - endif - if (use_dust) then - call read_inopt(dtg,'dust_to_gas_ratio',db,ierr) - call read_inopt(ndusttypes,'ndusttypes',db,ierr) - if (ndusttypes > 1) then - call read_inopt(smincgs,'smincgs',db,ierr) - call read_inopt(smaxcgs,'smaxcgs',db,ierr) - call read_inopt(sindex,'cs_sphere',db,ierr) - call read_inopt(graindenscgs,'graindenscgs',db,ierr) - else - call read_inopt(grainsizecgs,'grainsizecgs',db,ierr) - call read_inopt(graindenscgs,'graindenscgs',db,ierr) - endif - endif - if (binary) then - call read_inopt(rho_pert_amp,'rho_pert_amp',db,ierr) - endif - call read_inopt(icreate_sinks_setup,'icreate_sinks',db,ierr) - if (icreate_sinks_setup==1) then - call read_inopt(h_acc_setup,'h_acc',db,ierr) - call read_inopt(r_crit_setup,'r_crit',db,ierr) - if (binary) then - call read_inopt(h_soft_sinksink_setup,'h_soft_sinksink',db,ierr) - endif - else - call read_inopt(rhofinal_setup,'rho_final',db,ierr) - endif - call close_db(db) - ! - ! parse units - ! - call select_unit(mass_unit,umass,nerr) - if (nerr /= 0) then - call error('setup_sphereinbox','mass unit not recognised') - ierr = ierr + 1 - endif - call select_unit(dist_unit,udist,nerr) - if (nerr /= 0) then - call error('setup_sphereinbox','length unit not recognised') - ierr = ierr + 1 - endif - - if (ierr > 0) then - print "(1x,a,i2,a)",'Setup_sphereinbox: ',nerr,' error(s) during read of setup file. Re-writing.' - endif - -end subroutine read_setupfile -!---------------------------------------------------------------- - !--Magnetic flux justification - ! This shows how the critical mass-to-flux values translates from CGS to code units. - ! - ! rmasstoflux_crit = 0.53/(3*pi)*sqrt(5./G) ! cgs units of g G^-1 cm^-2 - ! convert base units from cgs to code: - ! rmasstoflux_crit = 0.53/(3*pi)*sqrt(5./G) *unit_Bfield*udist**2/umass - ! where - ! unit_Bfield = umass/(utime*sqrt(umass*udist/4*pi)) = sqrt(4.*pi*umass)/(utime*sqrt(udist)) - ! therefore - ! rmasstoflux_crit = 0.53/(3*pi)*sqrt(5./G) *sqrt(4.*pi*umass)*udist**2/(utime*sqrt(udist)*umass) - ! rmasstoflux_crit = (2/3)*0.53*sqrt(5./(G*pi))*sqrt(umass)*udist**2/(utime*sqrt(udist)*umass) - ! rmasstoflux_crit = (2/3)*0.53*sqrt(5./(G*pi))*udist**1.5/ (sqrt(umass)*utime) - ! where - ! G [cgs] = 1 * udist**3/(umass*utime**2) - ! therefore - ! rmasstoflux_crit = (2/3)*0.53*sqrt(5./pi) *udist**1.5/ (sqrt(umass)*utime) / sqrt(udist**3/(umass*utime**2)) - ! rmasstoflux_crit = (2/3)*0.53*sqrt(5./pi) ! code units - -!---------------------------------------------------------------- -end module setup From dc645852c41fa1cef88dd57fe6a18d3c78a74f19 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 18 Oct 2024 08:55:39 +1100 Subject: [PATCH 067/134] (apr) further PR issues fixed --- src/main/apr.f90 | 2 +- src/main/initial.F90 | 4 +--- src/main/part.F90 | 4 ++-- src/setup/setup_star.f90 | 21 +++++++++------------ 4 files changed, 13 insertions(+), 18 deletions(-) diff --git a/src/main/apr.f90 b/src/main/apr.f90 index bd6574419..05a0ea398 100644 --- a/src/main/apr.f90 +++ b/src/main/apr.f90 @@ -595,7 +595,7 @@ subroutine write_options_apr(iunit) use infile_utils, only:write_inopt integer, intent(in) :: iunit - write(iwritein,"(/,a)") '# options for adaptive particle refinement' + write(iunit,"(/,a)") '# options for adaptive particle refinement' call write_inopt(apr_max_in,'apr_max','number of additional refinement levels (3 -> 2x resolution)',iunit) call write_inopt(ref_dir,'ref_dir','increase (1) or decrease (-1) resolution',iunit) call write_inopt(apr_type,'apr_type','1: static, 2: moving sink, 3: create clumps',iunit) diff --git a/src/main/initial.F90 b/src/main/initial.F90 index 85725ab50..aaeb33633 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -96,11 +96,9 @@ subroutine initialise() ! !--initialise openMP things if required ! -! if (id==master) call print_cpuinfo() ! I have no idea why this doesn't work on my laptop - print*,'cpu info' + if (id==master) call print_cpuinfo() if (id==master) call info_omp call init_omp - print*,'init_omp' ! !--initialise MPI domains ! diff --git a/src/main/part.F90 b/src/main/part.F90 index 5d79d7c66..a52eb16cd 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -1591,7 +1591,7 @@ subroutine fill_sendbuf(i,xtemp,nbuf) call fill_buffer(xtemp,twas(i),nbuf) endif call fill_buffer(xtemp,iorig(i),nbuf) - ! call fill_buffer(xtemp,apr_level(i),nbuf) + if (use_apr) call fill_buffer(xtemp,apr_level(i),nbuf) endif if (nbuf > ipartbufsize) call fatal('fill_sendbuf','error: send buffer size overflow',var='nbuf',ival=nbuf) @@ -1677,7 +1677,7 @@ subroutine unfill_buffer(ipart,xbuf) twas(ipart) = unfill_buf(xbuf,j) endif iorig(ipart) = nint(unfill_buf(xbuf,j),kind=8) -! apr_level(ipart) = nint(unfill_buf(xbuf,j),kind=kind(apr_level)) + if (use_apr) apr_level(ipart) = nint(unfill_buf(xbuf,j),kind=kind(apr_level)) !--just to be on the safe side, set other things to zero if (mhd) then diff --git a/src/setup/setup_star.f90 b/src/setup/setup_star.f90 index a0d5f5020..26c310081 100644 --- a/src/setup/setup_star.f90 +++ b/src/setup/setup_star.f90 @@ -302,10 +302,7 @@ subroutine write_setupfile(filename,gamma,polyk) call write_inopt(write_rho_to_file,'write_rho_to_file','write density profile(s) to file',iunit) - if (use_apr) then - write(iunit,"(/,a)") '# apr options' - call write_options_apr(iunit) - endif + if (use_apr) call write_options_apr(iunit) close(iunit) @@ -379,19 +376,19 @@ subroutine read_setupfile(filename,gamma,polyk,need_iso,ierr) ! option to write density profile to file call read_inopt(write_rho_to_file,'write_rho_to_file',db) + if (use_apr) then + call read_inopt(apr_max_in,'apr_max',db,errcount=nerr) + call read_inopt(ref_dir,'ref_dir',db,errcount=nerr) + call read_inopt(apr_type,'apr_type',db,errcount=nerr) + call read_inopt(apr_rad,'apr_rad',db,errcount=nerr) + call read_inopt(apr_drad,'apr_drad',db,errcount=nerr) + endif + if (nerr > 0) then print "(1x,a,i2,a)",'setup_star: ',nerr,' error(s) during read of setup file' ierr = 1 endif - if (use_apr) then - call read_inopt(apr_max_in,'apr_max',db) - call read_inopt(ref_dir,'ref_dir',db) - call read_inopt(apr_type,'apr_type',db) - call read_inopt(apr_rad,'apr_rad',db) - call read_inopt(apr_drad,'apr_drad',db) - endif - call close_db(db) end subroutine read_setupfile From a15640cdeec27c0290805a2a045033377724bc35 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 18 Oct 2024 09:04:11 +1100 Subject: [PATCH 068/134] (apr) use checkval in test_apr --- src/tests/test_apr.f90 | 21 +++++---------------- 1 file changed, 5 insertions(+), 16 deletions(-) diff --git a/src/tests/test_apr.f90 b/src/tests/test_apr.f90 index 8790d53c0..002768959 100644 --- a/src/tests/test_apr.f90 +++ b/src/tests/test_apr.f90 @@ -18,7 +18,7 @@ module testapr ! part, physcon, testutils, unifdis, units ! use testutils, only:checkval,update_test_scores - use io, only:id,master + use io, only:id,master,fatal implicit none public :: test_apr,setup_apr_region_for_test @@ -32,10 +32,7 @@ module testapr !+ !-------------------------------------------- subroutine test_apr(ntests,npass) - use physcon, only:solarm,kpc - use units, only:set_units use unifdis, only:set_unifdis - use io, only:id,master,fatal use boundary, only:dxbound,dybound,dzbound,xmin,xmax,ymin,ymax,zmin,zmax use part, only:npart,npartoftype,hfact,xyzh,init_part,massoftype use part, only:isetphase,igas,iphase,vxyzu,fxyzu,apr_level @@ -45,7 +42,7 @@ subroutine test_apr(ntests,npass) use apr, only:apr_centre,update_apr integer, intent(inout) :: ntests,npass real :: psep,rhozero,time,totmass - integer :: original_npart,splitted + integer :: original_npart,splitted,nfailed(1) if (use_apr) then if (id==master) write(*,"(/,a)") '--> TESTING APR MODULE' @@ -54,8 +51,6 @@ subroutine test_apr(ntests,npass) return endif - ntests = 1 - ! Set up a uniform box of particles call init_part() psep = dxbound/20. @@ -68,7 +63,7 @@ subroutine test_apr(ntests,npass) hfact,npart,xyzh,periodic,mask=i_belong) original_npart = npart - massoftype(1) = totmass/reduceall_mpi('+',npart) + massoftype(igas) = totmass/reduceall_mpi('+',npart) iphase(1:npart) = isetphase(igas,iactive=.true.) ! Now set up an APR zone @@ -82,11 +77,8 @@ subroutine test_apr(ntests,npass) call update_apr(npart,xyzh,vxyzu,fxyzu,apr_level) ! Check that the original particle number returns - if (npart == original_npart) then - npass = 1 - else - npass = 0 - endif + call checkval(npart,original_npart,0,nfailed(1),'number of particles == original number') + call update_test_scores(ntests,nfailed,npass) if (id==master) write(*,"(/,a)") '<-- APR TEST COMPLETE' @@ -101,8 +93,6 @@ subroutine setup_apr_region_for_test() use apr, only:init_apr,update_apr,apr_max_in,ref_dir use apr, only:apr_type,apr_rad use part, only:npart,xyzh,vxyzu,fxyzu,apr_level - use linklist, only:set_linklist - !real :: ratesq(nrates) integer :: ierr if (id==master) write(*,"(/,a)") '--> adding an apr region' @@ -114,7 +104,6 @@ subroutine setup_apr_region_for_test() ! reserved for the test suite apr_rad = 0.25 ! radius of innermost region - ! initialise call init_apr(apr_level,ierr) call update_apr(npart,xyzh,vxyzu,fxyzu,apr_level) From 1a6340c9bc01b522f9c49a713837992472b00da6 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 18 Oct 2024 09:09:52 +1100 Subject: [PATCH 069/134] (apr) further issues fixed --- src/main/apr.f90 | 1 + src/main/relaxem.f90 | 6 ++++++ 2 files changed, 7 insertions(+) diff --git a/src/main/apr.f90 b/src/main/apr.f90 index 05a0ea398..8ce50d2a7 100644 --- a/src/main/apr.f90 +++ b/src/main/apr.f90 @@ -623,6 +623,7 @@ subroutine closest_neigh(i,next_door,rmin) real :: dx,dy,dz,rtest integer :: j + ! DP note: this is not MPI safe... rmin = huge(rmin) next_door = 0 do j = 1,npart diff --git a/src/main/relaxem.f90 b/src/main/relaxem.f90 index fc7ab99af..417896bf1 100644 --- a/src/main/relaxem.f90 +++ b/src/main/relaxem.f90 @@ -24,6 +24,8 @@ module relaxem ! Subroutine to relax the new set of particles to a reference particle distribution subroutine relax_particles(npart,n_ref,xyzh_ref,force_ref,nrelax,relaxlist) use deriv, only:get_derivs_global + use dim, only:mpi + use io, only:error integer, intent(in) :: npart,n_ref,nrelax real, intent(in) :: force_ref(3,n_ref),xyzh_ref(4,n_ref) integer, intent(in) :: relaxlist(1:nrelax) @@ -33,6 +35,10 @@ subroutine relax_particles(npart,n_ref,xyzh_ref,force_ref,nrelax,relaxlist) integer :: ishift,nshifts write(*,"(/,70('-'),/,/,2x,a,/,/)") 'APR: time to relax ...' + if (mpi) then + call error('APR','relax_particles is not compatible with MPI') + return + endif write(*,"(1x,1(a,i8,a,i8,a))") 'Relaxing',nrelax,' particles the heavenly way from',n_ref,' references.' From eda6c81fb772e55c5738409fe48255c2d7946923 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 18 Oct 2024 13:29:16 +1100 Subject: [PATCH 070/134] (apr) do not warn about missing apr arrays if no apr set --- src/main/readwrite_dumps_common.f90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/main/readwrite_dumps_common.f90 b/src/main/readwrite_dumps_common.f90 index 7451c66c4..df6fc8a8b 100644 --- a/src/main/readwrite_dumps_common.f90 +++ b/src/main/readwrite_dumps_common.f90 @@ -794,7 +794,7 @@ subroutine check_arrays(i1,i2,noffset,npartoftype,npartread,nptmass,nsinkpropert ierr = ierr + 1 endif if (.not.got_radprop(ikappa)) then - if (id==master .and. i1==1) write(*,"(/,a,/)") 'WARNING: RADIATION=yes but opacity not found in Phantom dump file' + if (id==master .and. i1==1) write(*,"(/,1x,a,/)") 'WARNING: RADIATION=yes but opacity not found in Phantom dump file' endif endif @@ -803,10 +803,10 @@ subroutine check_arrays(i1,i2,noffset,npartoftype,npartread,nptmass,nsinkpropert ! if (mhd) then if (.not.all(got_Bxyz(1:3))) then - if (id==master .and. i1==1) write(*,"(/,a,/)") 'WARNING: MHD but magnetic field arrays not found in Phantom dump file' + if (id==master .and. i1==1) write(*,"(/,1x,a,/)") 'WARNING: MHD but magnetic field arrays not found in Phantom dump file' endif if (.not.got_psi) then - if (id==master .and. i1==1) write(*,"(/,a,/)") & + if (id==master .and. i1==1) write(*,"(/,1x,a,/)") & 'WARNING! div B cleaning field (Psi) not found in Phantom dump file: assuming psi=0' Bevol(maxBevol,i1:i2) = 0. endif @@ -817,7 +817,7 @@ subroutine check_arrays(i1,i2,noffset,npartoftype,npartread,nptmass,nsinkpropert ! if (gr) then if (.not.all(got_pxyzu(1:3))) then - write(*,"(/,a,/)") 'WARNING: GR but momentum arrays not found in Phantom dump file' + write(*,"(/,1x,a,/)") 'WARNING: GR but momentum arrays not found in Phantom dump file' pxyzu(:,i1:i2) = 0. endif endif @@ -826,7 +826,7 @@ subroutine check_arrays(i1,i2,noffset,npartoftype,npartread,nptmass,nsinkpropert ! if (do_nucleation) then if (.not.all(got_nucleation)) then - write(*,"(/,a,/)") 'WARNING: DUST_NUCLEATION=yes but nucleation arrays not found in Phantom dump file' + write(*,"(/,1x,a,/)") 'WARNING: DUST_NUCLEATION=yes but nucleation arrays not found in Phantom dump file' call init_nucleation() endif endif @@ -839,7 +839,7 @@ subroutine check_arrays(i1,i2,noffset,npartoftype,npartread,nptmass,nsinkpropert iorig(i) = i + noffset enddo norig = i2 - if (id==master .and. i1==1) write(*,"(/,a,/)") 'WARNING: Particle IDs not in dump; resetting IDs' + if (id==master .and. i1==1) write(*,"(/,1x,a,/)") 'WARNING: Particle IDs not in dump; resetting IDs' else norig = 0 do i=i1,i2 @@ -850,11 +850,11 @@ subroutine check_arrays(i1,i2,noffset,npartoftype,npartread,nptmass,nsinkpropert ! ! APR ! - if (.not.got_apr_level) then + if (use_apr .and. .not.got_apr_level) then do i = i1,i2 apr_level(i) = 1 enddo - if (id==master .and. i1==1) write(*,"(/,a,/)") 'WARNING: APR levels not in dump; setting to default' + if (id==master .and. i1==1) write(*,"(/,1x,a,/)") 'WARNING: APR levels not in dump; setting to default' endif end subroutine check_arrays From c5c200ef9b83eb72dc8ceaab1fe92a7e231a5e75 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 18 Oct 2024 13:30:25 +1100 Subject: [PATCH 071/134] (apr) implemented get_mass_coord routine in relax_star to clean this up; added unit tests for this --- build/Makefile | 14 ++--- src/main/utils_sort.f90 | 24 ++++++++- src/setup/relax_star.f90 | 111 +++++++++++++++++++++++++-------------- src/tests/testsuite.F90 | 13 ++++- 4 files changed, 116 insertions(+), 46 deletions(-) diff --git a/build/Makefile b/build/Makefile index a6f2abbd9..80f4cf481 100644 --- a/build/Makefile +++ b/build/Makefile @@ -658,12 +658,14 @@ libsetup: $(OBJLIBSETUP) .PHONY: phantomsetup phantomsetup: setup -SRCSETUP= prompting.f90 utils_omp.F90 setup_params.f90 \ +SRCSETSTAR= prompting.f90 density_profiles.f90 readwrite_kepler.f90 readwrite_mesa.f90 \ + set_cubic_core.f90 set_fixedentropycore.f90 set_softened_core.f90 \ + set_star_utils.f90 relax_star.f90 set_star.f90 + +SRCSETUP= utils_omp.F90 setup_params.f90 \ set_dust_options.f90 set_units.f90 \ - density_profiles.f90 readwrite_kepler.f90 readwrite_mesa.f90 \ - set_slab.f90 set_disc.F90 set_orbit.f90 \ - set_cubic_core.f90 set_fixedentropycore.f90 set_softened_core.f90 \ - set_star_utils.f90 relax_star.f90 set_star.f90 set_hierarchical.f90 \ + ${SRCSETSTAR} set_slab.f90 set_disc.F90 set_orbit.f90 \ + set_hierarchical.f90 \ set_vfield.f90 set_Bfield.f90 \ ${SETUPFILE} @@ -694,7 +696,7 @@ SRCTESTS=utils_testsuite.f90 ${TEST_FASTMATH} test_kernel.f90 \ test_nonidealmhd.F90 directsum.f90 test_gravity.f90 \ test_derivs.F90 test_cooling.f90 test_eos_stratified.f90 \ test_eos.f90 test_externf.f90 test_rwdump.f90 \ - test_step.F90 test_indtstep.F90 set_disc.F90 test_setdisc.F90 \ + test_step.F90 test_indtstep.F90 ${SRCSETSTAR} set_disc.F90 test_setdisc.F90 test_setstar.f90 \ test_hierarchical.f90 test_damping.f90 test_wind.f90 test_iorig.f90 \ test_link.F90 test_kdtree.F90 test_part.f90 test_ptmass.f90 test_luminosity.F90\ test_gnewton.f90 test_corotate.f90 test_geometry.f90 \ diff --git a/src/main/utils_sort.f90 b/src/main/utils_sort.f90 index dba9c1ecf..38226e4df 100644 --- a/src/main/utils_sort.f90 +++ b/src/main/utils_sort.f90 @@ -17,7 +17,9 @@ module sortutils ! :Dependencies: None ! implicit none - public :: indexx,indexxfunc,Knnfunc,parqsort,find_rank,r2func,r2func_origin,set_r2func_origin + public :: indexx,indexxfunc,Knnfunc,parqsort,find_rank + public :: sort_by_radius + public :: r2func,r2func_origin,set_r2func_origin interface indexx module procedure indexx_r4, indexx_i8 end interface indexx @@ -642,4 +644,24 @@ subroutine find_rank(npart,func,xyzh,ranki) end subroutine find_rank +!---------------------------------------------------------------- +!+ +! simplified interface to sort by radius given 3D cartesian +! coordinates as input +!+ +!---------------------------------------------------------------- +subroutine sort_by_radius(n,xyz,iorder,x0) + integer, intent(in) :: n + real, intent(in) :: xyz(3,n) + integer, intent(out) :: iorder(n) + real, intent(in), optional :: x0(3) + + ! optional argument x0=[1,1,1] to set the origin + if (present(x0)) call set_r2func_origin(x0(1),x0(2),x0(3)) + + ! sort by r^2 using the r2func function + call indexxfunc(n,r2func,xyz,iorder) + +end subroutine sort_by_radius + end module sortutils diff --git a/src/setup/relax_star.f90 b/src/setup/relax_star.f90 index fc6e0d23d..6eb0af034 100644 --- a/src/setup/relax_star.f90 +++ b/src/setup/relax_star.f90 @@ -25,6 +25,7 @@ module relaxstar ! implicit none public :: relax_star,write_options_relax,read_options_relax + public :: get_mass_coord ! checked in test suite real, private :: tol_ekin = 1.e-7 ! criteria for being converged integer, private :: maxits = 1000 @@ -377,7 +378,6 @@ end subroutine shift_particles subroutine reset_u_and_get_errors(i1,npart,xyzh,vxyzu,rad,nt,mr,rho,& utherm,entrop,fix_entrop,rmax,rmserr) use table_utils, only:yinterp - use sortutils, only:find_rank,r2func use part, only:rhoh,massoftype,igas,maxvxyzu,ll use part, only:apr_level,aprmassoftype use dim, only:do_radiation,use_apr @@ -387,67 +387,102 @@ subroutine reset_u_and_get_errors(i1,npart,xyzh,vxyzu,rad,nt,mr,rho,& real, intent(inout) :: vxyzu(:,:),rad(:,:) real, intent(out) :: rmax,rmserr logical, intent(in) :: fix_entrop - real :: rj,rhor,rhoj,rho1,mstar,massrj,pmassj - integer :: i,j,rankj,rank_prev,npart_with_rank_prev - integer, allocatable :: iorder(:) - logical, allocatable :: iorder_mask(:) + real :: ri,rhor,rhoi,rho1,mstar,massri,pmassi + real, allocatable :: mass_enclosed_r(:) + integer :: i rho1 = yinterp(rho,mr,0.) rmax = 0. rmserr = 0. - ll = 0 ! this reassignment without changing length is essential for apr - allocate(iorder(npart-i1)) - call find_rank(npart-i1,r2func,xyzh(1:3,i1+1:npart),iorder) - ll(1:npart-i1) = iorder(1:npart-i1) + call get_mass_coord(i1,npart,xyzh,mass_enclosed_r) + print*,' mass enclosed is ',maxval(mass_enclosed_r) mstar = mr(nt) - allocate(iorder_mask(size(iorder))) - iorder_mask = .true. - rank_prev = 0 - massrj = 0. do i = i1+1,npart - if (use_apr) then - rankj = minval(iorder,mask=iorder_mask) ! Start from innermost to outermost particles - j = sum(minloc(iorder,mask=iorder_mask)) ! ID of first particle with iorder==rankj. Ignore the sum, doesn't do anything in practice. - iorder_mask(j) = .false. ! Eliminate this particle from next loop - npart_with_rank_prev = count(iorder==rank_prev) ! note that this is 0 for rankj=1 - pmassj = aprmassoftype(igas,apr_level(j)) ! replace with actual particle mass - else - j = i - pmassj = massoftype(igas) ! replace with actual particle mass - endif - - rj = sqrt(dot_product(xyzh(1:3,j),xyzh(1:3,j))) + ri = sqrt(dot_product(xyzh(1:3,i),xyzh(1:3,i))) + massri = mass_enclosed_r(i-i1)/mstar + rhor = yinterp(rho,mr,massri) ! analytic rho(r) if (use_apr) then - if (rankj/=rank_prev) massrj = massrj + real(npart_with_rank_prev)*pmassj ! for rankj=1, this correctly gives 0 - rank_prev = rankj + pmassi = aprmassoftype(igas,apr_level(i)) else - massrj = mstar * real(iorder(i-i1)-1) / real(npart-i1) + pmassi = massoftype(igas) endif - ! print*,'rankj=',rankj,'rank_prev=',rank_prev,'npartwithrankprev=',npart_with_rank_prev,'rj=',rj,'massri/pmass=',massrj/pmassj - ! read* - - rhor = yinterp(rho,mr,massrj) ! analytic rho(r) - rhoj = rhoh(xyzh(4,j),pmassj) ! actual rho + rhoi = rhoh(xyzh(4,i),pmassi) ! actual rho if (maxvxyzu >= 4) then if (fix_entrop) then - vxyzu(4,j) = (yinterp(entrop,mr,massrj)*rhoj**(gamma-1.))/(gamma-1.) + vxyzu(4,i) = (yinterp(entrop,mr,massri)*rhoi**(gamma-1.))/(gamma-1.) else - vxyzu(4,j) = yinterp(utherm,mr,massrj) + vxyzu(4,i) = yinterp(utherm,mr,massri) endif endif - rmserr = rmserr + (rhor - rhoj)**2 - rmax = max(rmax,rj) + rmserr = rmserr + (rhor - rhoi)**2 + rmax = max(rmax,ri) enddo if (do_radiation) rad = 0. rmserr = sqrt(rmserr/npart)/rho1 - deallocate(iorder,iorder_mask) + deallocate(mass_enclosed_r) end subroutine reset_u_and_get_errors +!---------------------------------------------------------------- +!+ +! get the mass coordinate of a particle m(r) +! this gives the mass enclosed EXCLUSIVE of self, i.e. m( tiny(0.)) then + massri = massri + mass_at_r + mass_at_r = pmassi + r2prev = r2 + else + mass_at_r = mass_at_r + pmassi + endif + mass_enclosed_r(j-i1) = massri + enddo + + ! clean up + deallocate(iorder) + +end subroutine get_mass_coord + !---------------------------------------------------------------- !+ ! set code options specific to relaxation calculations diff --git a/src/tests/testsuite.F90 b/src/tests/testsuite.F90 index a33837b84..e66c73210 100644 --- a/src/tests/testsuite.F90 +++ b/src/tests/testsuite.F90 @@ -60,6 +60,7 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) use testindtstep, only:test_indtstep use testrwdump, only:test_rwdump use testsetdisc, only:test_setdisc + use testsetstar, only:test_setstar use testsethier, only:test_sethier use testeos, only:test_eos use testcooling, only:test_cooling @@ -80,7 +81,7 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) integer, intent(inout) :: ntests,npass,nfail logical :: testall,dolink,dokdtree,doderivs,dokernel,dostep,dorwdump,dosmol logical :: doptmass,dognewton,dosedov,doexternf,doindtstep,dogravity,dogeom - logical :: dosetdisc,doeos,docooling,dodust,donimhd,docorotate,doany,dogrowth + logical :: dosetdisc,dosetstar,doeos,docooling,dodust,donimhd,docorotate,doany,dogrowth logical :: dogr,doradiation,dopart,dopoly,dompi,dohier,dodamp,dowind,& doiorig,doapr #ifdef FINVSQRT @@ -123,6 +124,7 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) dogravity = .false. dorwdump = .false. dosetdisc = .false. + dosetstar = .false. doeos = .false. dodust = .false. dogrowth = .false. @@ -195,6 +197,8 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) dorwdump = .true. case('setdisc','disc') dosetdisc = .true. + case('setstar','star') + dosetstar = .true. case('eos') doeos = .true. case('dust') @@ -388,6 +392,13 @@ subroutine testsuite(string,first,last,ntests,npass,nfail) call set_default_options_testsuite(iverbose) ! restore defaults endif ! +!--test of set_star module +! + if (dosetstar.or.testall) then + call test_setstar(ntests,npass) + call set_default_options_testsuite(iverbose) ! restore defaults + endif +! !--test of set_hier module ! if (dohier.or.testall) then From 137c42ac0297313e701e869f61b7ed2df3c9ee16 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 18 Oct 2024 13:34:10 +1100 Subject: [PATCH 072/134] (apr) implemented get_mass_coord routine in relax_star to clean this up; added unit tests for this --- src/setup/relax_star.f90 | 69 ++++------------------------------------ 1 file changed, 6 insertions(+), 63 deletions(-) diff --git a/src/setup/relax_star.f90 b/src/setup/relax_star.f90 index 6eb0af034..b2f0ecaff 100644 --- a/src/setup/relax_star.f90 +++ b/src/setup/relax_star.f90 @@ -25,7 +25,6 @@ module relaxstar ! implicit none public :: relax_star,write_options_relax,read_options_relax - public :: get_mass_coord ! checked in test suite real, private :: tol_ekin = 1.e-7 ! criteria for being converged integer, private :: maxits = 1000 @@ -377,11 +376,12 @@ end subroutine shift_particles !---------------------------------------------------------------- subroutine reset_u_and_get_errors(i1,npart,xyzh,vxyzu,rad,nt,mr,rho,& utherm,entrop,fix_entrop,rmax,rmserr) - use table_utils, only:yinterp - use part, only:rhoh,massoftype,igas,maxvxyzu,ll - use part, only:apr_level,aprmassoftype - use dim, only:do_radiation,use_apr - use eos, only:gamma + use table_utils, only:yinterp + use part, only:rhoh,massoftype,igas,maxvxyzu,ll + use part, only:apr_level,aprmassoftype + use dim, only:do_radiation,use_apr + use eos, only:gamma + use setstar_utils, only:get_mass_coord integer, intent(in) :: i1,npart,nt real, intent(in) :: xyzh(:,:),mr(nt),rho(nt),utherm(nt),entrop(nt) real, intent(inout) :: vxyzu(:,:),rad(:,:) @@ -396,7 +396,6 @@ subroutine reset_u_and_get_errors(i1,npart,xyzh,vxyzu,rad,nt,mr,rho,& rmserr = 0. call get_mass_coord(i1,npart,xyzh,mass_enclosed_r) - print*,' mass enclosed is ',maxval(mass_enclosed_r) mstar = mr(nt) do i = i1+1,npart @@ -427,62 +426,6 @@ subroutine reset_u_and_get_errors(i1,npart,xyzh,vxyzu,rad,nt,mr,rho,& end subroutine reset_u_and_get_errors -!---------------------------------------------------------------- -!+ -! get the mass coordinate of a particle m(r) -! this gives the mass enclosed EXCLUSIVE of self, i.e. m( tiny(0.)) then - massri = massri + mass_at_r - mass_at_r = pmassi - r2prev = r2 - else - mass_at_r = mass_at_r + pmassi - endif - mass_enclosed_r(j-i1) = massri - enddo - - ! clean up - deallocate(iorder) - -end subroutine get_mass_coord - !---------------------------------------------------------------- !+ ! set code options specific to relaxation calculations From 0e6bb18ae0f7ad8db79b4aecab2516a1292d0cec Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 18 Oct 2024 14:42:46 +1100 Subject: [PATCH 073/134] (test_setstar) added polytrope unit test along with bug fixes to get_mass_coord --- src/setup/relax_star.f90 | 22 +++- src/setup/set_star.f90 | 21 ++-- src/setup/set_star_utils.f90 | 71 +++++++++++-- src/tests/test_setstar.f90 | 189 +++++++++++++++++++++++++++++++++++ 4 files changed, 287 insertions(+), 16 deletions(-) create mode 100644 src/tests/test_setstar.f90 diff --git a/src/setup/relax_star.f90 b/src/setup/relax_star.f90 index b2f0ecaff..f081f1f4f 100644 --- a/src/setup/relax_star.f90 +++ b/src/setup/relax_star.f90 @@ -56,7 +56,8 @@ module relaxstar ! xyzh(:,:) - positions and smoothing lengths of all particles !+ !---------------------------------------------------------------- -subroutine relax_star(nt,rho,pr,r,npart,xyzh,use_var_comp,Xfrac,Yfrac,mu,ierr,npin,label) +subroutine relax_star(nt,rho,pr,r,npart,xyzh,use_var_comp,Xfrac,Yfrac,mu,ierr,npin,label,& + write_dumps,density_error,energy_error) use table_utils, only:yinterp use deriv, only:get_derivs_global use dim, only:maxp,maxvxyzu,gr,gravity,use_apr @@ -85,17 +86,24 @@ subroutine relax_star(nt,rho,pr,r,npart,xyzh,use_var_comp,Xfrac,Yfrac,mu,ierr,np integer, intent(out) :: ierr integer, intent(in), optional :: npin character(len=*), intent(in), optional :: label + logical, intent(in), optional :: write_dumps + real, intent(out), optional :: density_error,energy_error integer :: nits,nerr,nwarn,iunit,i1 real :: t,dt,dtmax,rmserr,rstar,mstar,tdyn real :: entrop(nt),utherm(nt),mr(nt),rmax,dtext,dtnew logical :: converged,use_step,restart logical, parameter :: fix_entrop = .true. ! fix entropy instead of thermal energy - logical, parameter :: write_files = .true. + logical :: write_files character(len=20) :: filename,mylabel i1 = 0 if (present(npin)) i1 = npin ! starting position in particle array ! + ! optional argument to not write files to disk + ! + write_files = .true. + if (present(write_dumps)) write_files = write_dumps + ! ! label for relax_star snapshots ! mylabel = '' @@ -204,6 +212,9 @@ subroutine relax_star(nt,rho,pr,r,npart,xyzh,use_var_comp,Xfrac,Yfrac,mu,ierr,np call init_step(npart,t,dtmax) endif nits = 0 + rmserr = 0. + ekin = 0. + epot = 1. ! to avoid compiler warning do while (.not. converged .and. nits < maxits) nits = nits + 1 ! @@ -283,6 +294,11 @@ subroutine relax_star(nt,rho,pr,r,npart,xyzh,use_var_comp,Xfrac,Yfrac,mu,ierr,np enddo if (write_files) close(iunit) ! + ! optional diagnostics + ! + if (present(density_error)) density_error = rmserr + if (present(energy_error)) energy_error = ekin/abs(epot) + ! ! warn if relaxation finished due to hitting nits=nitsmax ! if (.not.converged) then @@ -377,7 +393,7 @@ end subroutine shift_particles subroutine reset_u_and_get_errors(i1,npart,xyzh,vxyzu,rad,nt,mr,rho,& utherm,entrop,fix_entrop,rmax,rmserr) use table_utils, only:yinterp - use part, only:rhoh,massoftype,igas,maxvxyzu,ll + use part, only:rhoh,massoftype,igas,maxvxyzu use part, only:apr_level,aprmassoftype use dim, only:do_radiation,use_apr use eos, only:gamma diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index cea8982c8..e30b604d3 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -124,7 +124,8 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& npart,npartoftype,massoftype,hfact,& xyzmh_ptmass,vxyz_ptmass,nptmass,ieos,polyk,gamma,X_in,Z_in,& relax,use_var_comp,write_rho_to_file,& - rhozero,npart_total,mask,ierr,x0,v0,itype) + rhozero,npart_total,mask,ierr,x0,v0,itype,& + write_files,density_error,energy_error) use centreofmass, only:reset_centreofmass use dim, only:do_radiation,gr,gravity,maxvxyzu use io, only:fatal,error,warning @@ -154,23 +155,28 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& real, intent(out) :: rhozero integer(kind=8), intent(out) :: npart_total integer, intent(out) :: ierr - real, intent(in), optional :: x0(3),v0(3) - integer, intent(in), optional :: itype + real, intent(in), optional :: x0(3),v0(3) + integer, intent(in), optional :: itype + logical, intent(in), optional :: write_files + real, intent(out), optional :: density_error,energy_error procedure(mask_prototype) :: mask integer :: npts,ierr_relax integer :: ncols_compo,npart_old,i real, allocatable :: r(:),den(:),pres(:),temp(:),en(:),mtab(:),Xfrac(:),Yfrac(:),mu(:) real, allocatable :: composition(:,:) - real :: rmin,rhocentre + real :: rmin,rhocentre,rmserr,en_err character(len=20), allocatable :: comp_label(:) character(len=30) :: lattice ! The lattice type if stretchmap is used - logical :: use_exactN,composition_exists + logical :: use_exactN,composition_exists,write_dumps use_exactN = .true. composition_exists = .false. ierr_relax = 0 rhozero = 0. npart_old = npart + write_dumps = .true. + ierr = 0 + if (present(write_files)) write_dumps = write_files ! ! do nothing if iprofile is invalid or zero (sink particle) ! @@ -237,7 +243,10 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& if (relax) then if (reduceall_mpi('+',npart)==npart) then call relax_star(npts,den,pres,r,npart,xyzh,use_var_comp,Xfrac,Yfrac,& - mu,ierr_relax,npin=npart_old,label=star%label) + mu,ierr_relax,npin=npart_old,label=star%label,& + write_dumps=write_dumps,density_error=rmserr,energy_error=en_err) + if (present(density_error)) density_error = rmserr + if (present(energy_error)) energy_error = en_err else call error('setup_star','cannot run relaxation with MPI setup, please run setup on ONE MPI thread') endif diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index eac6dedf8..7b0e3c663 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -50,6 +50,7 @@ module setstar_utils public :: set_stellar_core public :: write_kepler_comp public :: need_inputprofile,need_polyk,need_rstar + public :: get_mass_coord private @@ -337,6 +338,62 @@ subroutine set_stellar_core(nptmass,xyzmh_ptmass,vxyz_ptmass,ihsoft,mcore,& end subroutine set_stellar_core +!---------------------------------------------------------------- +!+ +! get the mass coordinate of a particle m(r) +! this gives the mass enclosed EXCLUSIVE of self, i.e. m( tiny(0.)) then + massri = massri + mass_at_r + mass_at_r = pmassi + r2prev = r2 + else + mass_at_r = mass_at_r + pmassi + endif + mass_enclosed_r(j-i1) = massri + enddo + + ! clean up + deallocate(iorder) + +end subroutine get_mass_coord + !----------------------------------------------------------------------- !+ ! Set the composition, if variable composition is used @@ -344,8 +401,7 @@ end subroutine set_stellar_core !----------------------------------------------------------------------- subroutine set_star_composition(use_var_comp,use_mu,npart,xyzh,Xfrac,Yfrac,& mu,mtab,Mstar,eos_vars,npin) - use part, only:iorder=>ll,iX,iZ,imu ! borrow the unused linklist array for the sort - use sortutils, only:find_rank,r2func + use part, only:iX,iZ,imu ! borrow the unused linklist array for the sort use table_utils, only:yinterp logical, intent(in) :: use_var_comp,use_mu integer, intent(in) :: npart @@ -353,17 +409,18 @@ subroutine set_star_composition(use_var_comp,use_mu,npart,xyzh,Xfrac,Yfrac,& real, intent(in) :: Xfrac(:),Yfrac(:),mu(:),mtab(:),Mstar real, intent(out) :: eos_vars(:,:) integer, intent(in), optional :: npin - real :: ri,massri + real, allocatable :: mass_enclosed_r(:) + real :: massri integer :: i,i1 i1 = 0 if (present(npin)) i1 = npin ! starting position in particle array ! this does NOT work with MPI - call find_rank(npart-i1,r2func,xyzh(1:3,i1:npart),iorder) + call get_mass_coord(i1,npart,xyzh,mass_enclosed_r) + do i = i1+1,npart - ri = sqrt(dot_product(xyzh(1:3,i),xyzh(1:3,i))) - massri = Mstar * real(iorder(i)-1) / real(npart-i1) ! mass coordinate of particle i + massri = mass_enclosed_r(i-i1)/Mstar if (use_var_comp) then eos_vars(iX,i) = yinterp(Xfrac,mtab,massri) eos_vars(iZ,i) = 1. - eos_vars(iX,i) - yinterp(Yfrac,mtab,massri) @@ -450,7 +507,6 @@ subroutine set_star_thermalenergy(ieos,den,pres,r,npts,npart,xyzh,vxyzu,rad,eos_ end subroutine set_star_thermalenergy - !----------------------------------------------------------------------- !+ ! Solve for u, T profiles given rho, P @@ -484,6 +540,7 @@ subroutine solve_uT_profiles(eos_type,r,den,pres,Xfrac,Yfrac,regrid_core,temp,en en(i) = eni temp(i) = tempi enddo + end subroutine solve_uT_profiles end module setstar_utils diff --git a/src/tests/test_setstar.f90 b/src/tests/test_setstar.f90 new file mode 100644 index 000000000..66318cc76 --- /dev/null +++ b/src/tests/test_setstar.f90 @@ -0,0 +1,189 @@ +!--------------------------------------------------------------------------! +! The Phantom Smoothed Particle Hydrodynamics code, by Daniel Price et al. ! +! Copyright (c) 2007-2024 The Authors (see AUTHORS) ! +! See LICENCE file for usage and distribution conditions ! +! http://phantomsph.github.io/ ! +!--------------------------------------------------------------------------! +module testsetstar +! +! Unit tests of set_star and relax_star modules +! +! :References: None +! +! :Owner: Daniel Price +! +! :Runtime parameters: None +! +! :Dependencies: +! + use testutils, only:checkval,update_test_scores + implicit none + public :: test_setstar + + private + +contains +!----------------------------------------------------------------------- +!+ +! Unit tests of the set_star routine and associated utilities +!+ +!----------------------------------------------------------------------- +subroutine test_setstar(ntests,npass) + use checksetup, only:check_setup + use io, only:id,master + use dim, only:gravity + integer, intent(inout) :: ntests,npass + + if (.not.gravity) then + if (id==master) write(*,"(/,a)") '--> SKIPPING STAR SETUP TESTS' + return + else + if (id==master) write(*,"(/,a,/)") '--> TESTING STAR SETUP' + endif + + ! test the get_mass_coordinate routine in relax_star + call test_get_mass_coord(ntests,npass) + + ! test polytrope + call test_polytrope(ntests,npass) + +end subroutine test_setstar + +!----------------------------------------------------------------------- +!+ +! Check that the procedure to get the Lagrangian mass coordinate +! from the radius works +!+ +!----------------------------------------------------------------------- +subroutine test_get_mass_coord(ntests,npass) + use sortutils, only:r2func,find_rank + use part, only:xyzh,massoftype,igas,iorder=>ll + use setstar_utils, only:get_mass_coord + use table_utils, only:linspace + use testutils, only:checkvalbuf,checkvalbuf_end + integer, intent(inout) :: ntests,npass + real, allocatable :: mass_enclosed_r(:) + integer :: i,i1,itest,np,nfail(1),ncheck + real :: massri,errmax + real, parameter :: tol = 1.e-14 + + i1 = 10 ! start at non-zero offset to check this + np = 100 + + ! place the particles in a line between x=[0,1] + xyzh(:,1:np) = 0. + call linspace(xyzh(1,i1+1:np),0.,1.) + + ! give them equal masses + massoftype(igas) = 3.e-6 + + ! call the routine we are trying to test + call get_mass_coord(i1,np,xyzh,mass_enclosed_r) + + ! check memory was allocated correctly + call checkval(size(mass_enclosed_r),np-i1,0,nfail(1),'size of mass_enclosed_r array') + call update_test_scores(ntests,nfail,npass) + + ! check that the mass ranking is correct + ncheck = 0 + nfail = 0 + do i=i1+1,np + call checkvalbuf(mass_enclosed_r(i-i1),(i-i1-1)*massoftype(igas),& + tol,'m(x) for particles in x=[0,1]',nfail(1),ncheck,errmax) + enddo + call checkvalbuf_end('m(x) for particles in x=[0,1]',ncheck,nfail(1),errmax,tol) + call update_test_scores(ntests,nfail,npass) + + do itest=1,2 + if (itest==2) then + ! now check pathological case where half the particles are at y=0, and half are at y=1 + xyzh(:,1:np) = 0. + xyzh(2,i1+np/2:np) = 1. + call get_mass_coord(i1,np,xyzh,mass_enclosed_r) + endif + ! + ! check that this agrees with our previous method that + ! works only for equal mass particles + ! + mass_enclosed_r = mass_enclosed_r / ((np-i1)*massoftype(igas)) ! make it a mass fraction + call find_rank(np-i1,r2func,xyzh(1:3,i1+1:np),iorder) + do i=i1+1,np + massri = real(iorder(i-i1)-1) / real(np-i1) + call checkvalbuf(mass_enclosed_r(i-i1),massri,tol,'m( Date: Fri, 18 Oct 2024 16:05:18 +1100 Subject: [PATCH 074/134] (apr) additional test failures fixed; added setstar to testgrav --- .github/workflows/test.yml | 2 +- build/Makefile | 4 ++-- src/main/apr.f90 | 11 +++++++++-- src/setup/set_star.f90 | 2 +- 4 files changed, 13 insertions(+), 6 deletions(-) diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 3c7a977e0..2a1dfe449 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -32,7 +32,7 @@ jobs: - ['testkd', ''] - ['testdust', 'dust'] - ['testgr', 'gr'] - - ['testgrav', 'gravity ptmass'] + - ['testgrav', 'gravity ptmass setstar'] - ['testgrowth', 'dustgrowth'] - ['testnimhd', 'nimhd'] - ['test2', ''] diff --git a/build/Makefile b/build/Makefile index 80f4cf481..e03c86fa2 100644 --- a/build/Makefile +++ b/build/Makefile @@ -663,8 +663,8 @@ SRCSETSTAR= prompting.f90 density_profiles.f90 readwrite_kepler.f90 readwrite_me set_star_utils.f90 relax_star.f90 set_star.f90 SRCSETUP= utils_omp.F90 setup_params.f90 \ - set_dust_options.f90 set_units.f90 \ - ${SRCSETSTAR} set_slab.f90 set_disc.F90 set_orbit.f90 \ + ${SRCSETSTAR} set_dust_options.f90 set_units.f90 \ + set_slab.f90 set_disc.F90 set_orbit.f90 \ set_hierarchical.f90 \ set_vfield.f90 set_Bfield.f90 \ ${SETUPFILE} diff --git a/src/main/apr.f90 b/src/main/apr.f90 index 8ce50d2a7..4be62ad6c 100644 --- a/src/main/apr.f90 +++ b/src/main/apr.f90 @@ -28,8 +28,15 @@ module apr public :: init_apr,update_apr,read_options_apr,write_options_apr public :: create_or_update_apr_clump - integer, public :: apr_max_in = 3, ref_dir = 1, apr_type = 1, apr_max - real, public :: apr_rad = 1.0, apr_drad = 0.1, apr_centre(3) + + ! default values for runtime parameters + integer, public :: apr_max_in = 3 + integer, public :: ref_dir = 1 + integer, public :: apr_type = 1 + integer, public :: apr_max = 4 + real, public :: apr_rad = 1.0 + real, public :: apr_drad = 0.1 + real, public :: apr_centre(3) = 0. private integer :: top_level = 1, ntrack = 0, track_part = 0 diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index e30b604d3..614cebe5f 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -270,7 +270,7 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& xyzh,Xfrac,Yfrac,mu,mtab,star%mstar,eos_vars,npin=npart_old) endif ! - ! Write composition file called kepler.comp containing composition of each particle after interpolation + ! Write .comp file containing composition of each particle after interpolation ! if (star%iprofile==iKepler) call write_kepler_comp(composition,comp_label,ncols_compo,r,& xyzh,npart,npts,composition_exists,npin=npart_old) From bb5e76139a5cff205be0c1b07dda45739ac52982 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 18 Oct 2024 16:08:47 +1100 Subject: [PATCH 075/134] (apr) minor formatting cleanups --- src/main/apr.f90 | 110 ++++++++++++++++++++-------------------- src/main/apr_region.f90 | 14 +++-- 2 files changed, 60 insertions(+), 64 deletions(-) diff --git a/src/main/apr.f90 b/src/main/apr.f90 index 4be62ad6c..c28fbc0c9 100644 --- a/src/main/apr.f90 +++ b/src/main/apr.f90 @@ -6,7 +6,7 @@ !--------------------------------------------------------------------------! module apr ! -! apr +! Everything needed for live adaptive particle refinement ! ! :References: None ! @@ -50,11 +50,11 @@ module apr contains - !----------------------------------------------------------------------- - !+ - ! Initialising all the apr arrays and properties - !+ - !----------------------------------------------------------------------- +!----------------------------------------------------------------------- +!+ +! Initialising all the apr arrays and properties +!+ +!----------------------------------------------------------------------- subroutine init_apr(apr_level,ierr) use dim, only:maxp_hard use part, only:npart,massoftype,aprmassoftype @@ -110,11 +110,11 @@ subroutine init_apr(apr_level,ierr) end subroutine init_apr - !----------------------------------------------------------------------- - !+ - ! Subroutine to check if particles need to be split or merged - !+ - !----------------------------------------------------------------------- +!----------------------------------------------------------------------- +!+ +! Subroutine to check if particles need to be split or merged +!+ +!----------------------------------------------------------------------- subroutine update_apr(npart,xyzh,vxyzu,fxyzu,apr_level) use dim, only:maxp_hard,ind_timesteps use part, only:ntot,isdead_or_accreted,igas,aprmassoftype,& @@ -276,12 +276,12 @@ subroutine update_apr(npart,xyzh,vxyzu,fxyzu,apr_level) end subroutine update_apr - !----------------------------------------------------------------------- - !+ - ! routine to return the adaptive particle refinement level based on position - ! and the boundaries set by the apr_* arrays - !+ - !----------------------------------------------------------------------- +!----------------------------------------------------------------------- +!+ +! routine to return the adaptive particle refinement level based on position +! and the boundaries set by the apr_* arrays +!+ +!----------------------------------------------------------------------- subroutine get_apr(pos,apri) use io, only:fatal use apr_region, only:apr_region_is_circle @@ -316,11 +316,11 @@ subroutine get_apr(pos,apri) end subroutine get_apr - !----------------------------------------------------------------------- - !+ - ! routine to split one particle into two - !+ - !----------------------------------------------------------------------- +!----------------------------------------------------------------------- +!+ +! routine to split one particle into two +!+ +!----------------------------------------------------------------------- subroutine splitpart(i,npartnew) use part, only:copy_particle_all,apr_level,xyzh,vxyzu,npartoftype,igas use part, only:set_particle_type @@ -418,12 +418,12 @@ subroutine splitpart(i,npartnew) end subroutine splitpart - !----------------------------------------------------------------------- - !+ - ! Take in all particles that *might* be merged at this apr_level - ! and use our special tree to merge what has left the region - !+ - !----------------------------------------------------------------------- +!----------------------------------------------------------------------- +!+ +! Take in all particles that *might* be merged at this apr_level +! and use our special tree to merge what has left the region +!+ +!----------------------------------------------------------------------- subroutine merge_with_special_tree(nmerge,mergelist,xyzh_merge,vxyzu_merge,current_apr,& xyzh,vxyzu,apr_level,nkilled,nrelax,relaxlist,npartnew) use linklist, only:set_linklist,ncells,ifirstincell,get_cell_location @@ -496,11 +496,11 @@ subroutine merge_with_special_tree(nmerge,mergelist,xyzh_merge,vxyzu_merge,curre end subroutine merge_with_special_tree - !----------------------------------------------------------------------- - !+ - ! reads input options from the input file - !+ - !----------------------------------------------------------------------- +!----------------------------------------------------------------------- +!+ +! reads input options from the input file +!+ +!----------------------------------------------------------------------- subroutine read_options_apr(name,valstring,imatch,igotall,ierr) use io, only:fatal character(len=*), intent(in) :: name,valstring @@ -542,12 +542,11 @@ subroutine read_options_apr(name,valstring,imatch,igotall,ierr) igotall = (ngot == 5) end subroutine read_options_apr - !----------------------------------------------------------------------- - !+ - ! extra subroutines for reading in different styles of apr zones - !+ - !----------------------------------------------------------------------- - +!----------------------------------------------------------------------- +!+ +! extra subroutines for reading in different styles of apr zones +!+ +!----------------------------------------------------------------------- subroutine read_options_apr1(name,valstring,imatch,igotall,ierr) use io, only:fatal character(len=*), intent(in) :: name,valstring @@ -593,11 +592,11 @@ subroutine read_options_apr2(name,valstring,imatch,igotall,ierr) end subroutine read_options_apr2 - !----------------------------------------------------------------------- - !+ - ! Writes input options to the input file. - !+ - !----------------------------------------------------------------------- +!----------------------------------------------------------------------- +!+ +! Writes input options to the input file. +!+ +!----------------------------------------------------------------------- subroutine write_options_apr(iunit) use infile_utils, only:write_inopt integer, intent(in) :: iunit @@ -649,11 +648,11 @@ subroutine closest_neigh(i,next_door,rmin) end subroutine closest_neigh - !----------------------------------------------------------------------- - !+ - ! routine to put a particle on the shortest timestep - !+ - !----------------------------------------------------------------------- +!----------------------------------------------------------------------- +!+ +! routine to put a particle on the shortest timestep +!+ +!----------------------------------------------------------------------- subroutine put_in_smallest_bin(i) use timestep_ind, only:nbinmax use part, only:ibin @@ -663,13 +662,12 @@ subroutine put_in_smallest_bin(i) end subroutine put_in_smallest_bin - !----------------------------------------------------------------------- - !+ - ! Create a new apr region that is centred on a dense clump - ! (This is work in progress) - !+ - !----------------------------------------------------------------------- - +!----------------------------------------------------------------------- +!+ +! Create a new apr region that is centred on a dense clump +! (This is work in progress) +!+ +!----------------------------------------------------------------------- subroutine create_or_update_apr_clump(npart,xyzh,vxyzu,poten,apr_level,xyzmh_ptmass,aprmassoftype) use apr_region, only:set_apr_centre use part, only:igas,rhoh diff --git a/src/main/apr_region.f90 b/src/main/apr_region.f90 index 986c4b943..947ce0464 100644 --- a/src/main/apr_region.f90 +++ b/src/main/apr_region.f90 @@ -6,7 +6,7 @@ !--------------------------------------------------------------------------! module apr_region ! -! apr_region +! Everything for setting the adaptive particle refinement regions ! ! :References: None ! @@ -25,12 +25,11 @@ module apr_region contains - !----------------------------------------------------------------------- - !+ - ! Setting/updating the centre of the apr region (as it may move) - !+ - !----------------------------------------------------------------------- - +!----------------------------------------------------------------------- +!+ +! Setting/updating the centre of the apr region (as it may move) +!+ +!----------------------------------------------------------------------- subroutine set_apr_centre(apr_type,apr_centre,ntrack,track_part) use part, only: xyzmh_ptmass,xyzh integer, intent(in) :: apr_type @@ -72,7 +71,6 @@ end subroutine set_apr_centre ! the spatial arrangement of the regions !+ !----------------------------------------------------------------------- - subroutine set_apr_regions(ref_dir,apr_max,apr_regions,apr_rad,apr_drad) integer, intent(in) :: ref_dir,apr_max real, intent(in) :: apr_rad,apr_drad From f50cb3eef69f1f9c74bc5481084aab682c36e354 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 18 Oct 2024 16:25:31 +1100 Subject: [PATCH 076/134] (apr) bug fix in options routines --- src/main/apr.f90 | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/main/apr.f90 b/src/main/apr.f90 index c28fbc0c9..3adf55d70 100644 --- a/src/main/apr.f90 +++ b/src/main/apr.f90 @@ -508,8 +508,11 @@ subroutine read_options_apr(name,valstring,imatch,igotall,ierr) integer, intent(out) :: ierr integer, save :: ngot = 0 character(len=30), parameter :: label = 'read_options_apr' + logical :: igotall1,igotall2 imatch = .true. + igotall1 = .true. + igotall2 = .true. select case(trim(name)) case('apr_max') read(valstring,*,iostat=ierr) apr_max_in @@ -533,13 +536,13 @@ subroutine read_options_apr(name,valstring,imatch,igotall,ierr) imatch = .false. select case(apr_type) case(1) - call read_options_apr1(name,valstring,imatch,igotall,ierr) + call read_options_apr1(name,valstring,imatch,igotall1,ierr) case(2) - call read_options_apr2(name,valstring,imatch,igotall,ierr) + call read_options_apr2(name,valstring,imatch,igotall2,ierr) end select end select + igotall = (ngot >= 5) .and. igotall1 .and. igotall2 - igotall = (ngot == 5) end subroutine read_options_apr !----------------------------------------------------------------------- @@ -569,6 +572,7 @@ subroutine read_options_apr1(name,valstring,imatch,igotall,ierr) case default imatch = .false. end select + igotall = (ngot >= 3) end subroutine read_options_apr1 @@ -589,6 +593,7 @@ subroutine read_options_apr2(name,valstring,imatch,igotall,ierr) case default imatch = .false. end select + igotall = (ngot >= 1) end subroutine read_options_apr2 From 606d2d58cc685a354c2c7642b4e9cd43d528ff42 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 18 Oct 2024 17:33:29 +1100 Subject: [PATCH 077/134] (apr) fix issues with memory allocation: allocate apr arrays to zero size if use_apr is false --- src/main/config.F90 | 62 ++++++++++++++++++++------------------------- src/main/part.F90 | 8 +++--- 2 files changed, 31 insertions(+), 39 deletions(-) diff --git a/src/main/config.F90 b/src/main/config.F90 index f33c52aea..1238e1ea6 100644 --- a/src/main/config.F90 +++ b/src/main/config.F90 @@ -26,7 +26,7 @@ module dim public character(len=80), parameter :: & - tagline='Phantom v'//phantom_version_string//' (c) 2007-2023 The Authors' + tagline='Phantom v'//phantom_version_string//' (c) 2007-2025 The Authors' ! maximum number of particles integer :: maxp = 0 ! memory not allocated initially @@ -113,11 +113,10 @@ module dim integer :: maxprad = 0 - integer, parameter :: & - radensumforce = 1,& - radenxpartvecforce = 7,& - radensumden = 3,& - radenxpartvetden = 1 + integer, parameter :: radensumforce = 1, & + radenxpartvecforce = 7, & + radensumden = 3, & + radenxpartvetden = 1 #ifdef RADIATION logical, parameter :: do_radiation = .true. #else @@ -331,11 +330,12 @@ module dim !-------------------- #ifdef APR logical, parameter :: use_apr = .true. - integer, parameter :: apr_maxhard = 10 + integer, parameter :: apr_maxlevel = 10 #else logical, parameter :: use_apr = .false. - integer, parameter :: apr_maxhard = 0 + integer, parameter :: apr_maxlevel = 0 #endif + integer :: maxp_apr = 0 !-------------------- ! individual timesteps @@ -373,7 +373,10 @@ subroutine update_max_sizes(n,ntot) integer(kind=8), optional, intent(in) :: ntot maxp = n - if (use_apr) maxp = 4*n + if (use_apr) then + maxp = 4*n + maxp_apr = maxp + endif if (use_krome) maxp_krome = maxp @@ -398,12 +401,10 @@ subroutine update_max_sizes(n,ntot) endif #endif -#ifdef DUST - maxp_dustfrac = maxp -#ifdef DUSTGROWTH - maxp_growth = maxp -#endif -#endif + if (use_dust) then + maxp_dustfrac = maxp + if (use_dustgrowth) maxp_growth = maxp + endif #ifdef DISC_VISCOSITY maxalpha = 0 @@ -419,20 +420,13 @@ subroutine update_max_sizes(n,ntot) #endif #endif -#ifdef MHD - maxmhd = maxp -#ifdef NONIDEALMHD - maxmhdni = maxp -#endif -#endif - -#ifdef GRAVITY - maxgrav = maxp -#endif + if (mhd) then + maxmhd = maxp + if (mhd_nonideal) maxmhdni = maxp + endif -#ifdef GR - maxgr = maxp -#endif + if (gravity) maxgrav = maxp + if (gr) maxgr = maxp #ifdef STS_TIMESTEPS #ifdef IND_TIMESTEPS @@ -451,14 +445,12 @@ subroutine update_max_sizes(n,ntot) maxgran = maxgr #endif -#ifdef IND_TIMESTEPS - maxindan = maxan -#endif + if (ind_timesteps) maxindan = maxan -#ifdef RADIATION - maxprad = maxp - maxlum = maxp -#endif + if (do_radiation) then + maxprad = maxp + maxlum = maxp + endif ! Very convoluted, but follows original logic... maxphase = maxan maxgradh = maxan diff --git a/src/main/part.F90 b/src/main/part.F90 index a52eb16cd..936d0d3d1 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -33,7 +33,7 @@ module part maxphase,maxgradh,maxan,maxdustan,maxmhdan,maxneigh,maxprad,maxp_nucleation,& maxTdust,store_dust_temperature,use_krome,maxp_krome, & do_radiation,gr,maxgr,maxgran,n_nden_phantom,do_nucleation,& - inucleation,itau_alloc,itauL_alloc,use_apr,apr_maxhard + inucleation,itau_alloc,itauL_alloc,use_apr,apr_maxlevel,maxp_apr use dtypekdtree, only:kdnode #ifdef KROME use krome_user, only: krome_nmols @@ -396,7 +396,7 @@ module part integer :: npartoftype(maxtypes) integer(kind=8) :: npartoftypetot(maxtypes) - real :: massoftype(maxtypes),aprmassoftype(maxtypes,apr_maxhard) + real :: massoftype(maxtypes),aprmassoftype(maxtypes,apr_maxlevel) integer :: ndustsmall,ndustlarge,ndusttypes ! @@ -449,8 +449,8 @@ subroutine allocate_part call allocate_array('dvdx', dvdx, 9, maxp) call allocate_array('divcurlB', divcurlB, ndivcurlB, maxp) call allocate_array('Bevol', Bevol, maxBevol, maxmhd) - call allocate_array('apr_level',apr_level,maxp) - call allocate_array('apr_level_soa',apr_level_soa,maxp) + call allocate_array('apr_level',apr_level,maxp_apr) + call allocate_array('apr_level_soa',apr_level_soa,maxp_apr) call allocate_array('Bxyz', Bxyz, 3, maxmhd) call allocate_array('iorig', iorig, maxp) call allocate_array('dustprop', dustprop, 2, maxp_growth) From 3a68a3e4a4bd91acf250b152af068b14f48e00b9 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 18 Oct 2024 17:34:39 +1100 Subject: [PATCH 078/134] (apr) put padding at end of structure --- src/main/mpi_dens.F90 | 4 +++- src/main/mpi_force.F90 | 4 +++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/src/main/mpi_dens.F90 b/src/main/mpi_dens.F90 index 19ef900ae..9986c8219 100644 --- a/src/main/mpi_dens.F90 +++ b/src/main/mpi_dens.F90 @@ -66,8 +66,10 @@ module mpidens integer :: nneigh(minpart) ! number of actual neighbours (diagnostic) integer :: waiting_index integer(kind=1) :: iphase(minpart) - integer(kind=1) :: pad(8 - mod(nbytes_celldens, 8)) integer(kind=1) :: apr(minpart) ! apr resolution level (not in xpartvec because integer) + + ! pad the array to 8-byte boundaries + integer(kind=1) :: pad(8 - mod(nbytes_celldens, 8)) end type celldens type stackdens diff --git a/src/main/mpi_force.F90 b/src/main/mpi_force.F90 index 7a6def3f5..f4ff7722e 100644 --- a/src/main/mpi_force.F90 +++ b/src/main/mpi_force.F90 @@ -68,8 +68,10 @@ module mpiforce integer :: waiting_index integer(kind=1) :: iphase(minpart) integer(kind=1) :: ibinneigh(minpart) - integer(kind=1) :: pad(8 - mod(nbytes_cellforce, 8)) !padding to maintain alignment of elements integer(kind=1) :: apr(minpart) ! apr resolution level (not in xpartvec because integer) + + ! pad the array to 8-byte boundaries + integer(kind=1) :: pad(8 - mod(nbytes_cellforce, 8)) !padding to maintain alignment of elements end type cellforce type stackforce From 5a1a3981e1665510bccfba24887b100cf2e02ab6 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 18 Oct 2024 18:03:03 +1100 Subject: [PATCH 079/134] (apr) more memory issues fixed --- src/main/kdtree.F90 | 29 +++++++++++++--------------- src/main/memory.f90 | 4 ++-- src/main/part.F90 | 6 ++---- src/main/readwrite_dumps_fortran.f90 | 8 +++++--- src/tests/test_radiation.f90 | 2 +- 5 files changed, 23 insertions(+), 26 deletions(-) diff --git a/src/main/kdtree.F90 b/src/main/kdtree.F90 index 313a67032..54d88049b 100644 --- a/src/main/kdtree.F90 +++ b/src/main/kdtree.F90 @@ -323,11 +323,10 @@ subroutine construct_root_node(np,nproot,irootnode,ndim,xmini,xmaxi,ifirstincell use boundary, only:cross_boundary use mpidomain,only:isperiodic #endif -#ifdef IND_TIMESTEPS use part, only:iphase,iactive -#endif use part, only:isdead_or_accreted use io, only:fatal + use dim, only:ind_timesteps integer, intent(in) :: np,irootnode,ndim integer, intent(out) :: nproot real, intent(out) :: xmini(ndim), xmaxi(ndim) @@ -383,21 +382,19 @@ subroutine construct_root_node(np,nproot,irootnode,ndim,xmini,xmaxi,ifirstincell isnotdead: if (.not.isdead_or_accreted(xyzh(4,i))) then nproot = nproot + 1 -#ifdef IND_TIMESTEPS - if (iactive(iphase(i))) then - inodeparts(nproot) = i ! +ve if active + if (ind_timesteps) then + if (iactive(iphase(i))) then + inodeparts(nproot) = i ! +ve if active + else + inodeparts(nproot) = -i ! -ve if inactive + endif + if (use_apr) inodeparts(nproot) = abs(inodeparts(nproot)) else - inodeparts(nproot) = -i ! -ve if inactive + inodeparts(nproot) = i endif - if (use_apr) inodeparts(nproot) = abs(inodeparts(nproot)) -#else - inodeparts(nproot) = i -#endif xyzh_soa(nproot,:) = xyzh(:,i) iphase_soa(nproot) = iphase(i) - if (use_apr) then - apr_level_soa(nproot) = apr_level(i) - endif + if (use_apr) apr_level_soa(nproot) = apr_level(i) endif isnotdead enddo @@ -888,17 +885,17 @@ subroutine sort_particles_in_cell(iaxis,imin,imax,min_l,max_l,min_r,max_r,nl,nr, inodeparts_swap = inodeparts(i) xyzh_swap(1:4) = xyzh_soa(i,1:4) iphase_swap = iphase_soa(i) - apr_swap = apr_level_soa(i) + if (use_apr) apr_swap = apr_level_soa(i) inodeparts(i) = inodeparts(j) xyzh_soa(i,1:4) = xyzh_soa(j,1:4) iphase_soa(i) = iphase_soa(j) - apr_level_soa(i)= apr_level_soa(j) + if (use_apr) apr_level_soa(i)= apr_level_soa(j) inodeparts(j) = inodeparts_swap xyzh_soa(j,1:4) = xyzh_swap(1:4) iphase_soa(j) = iphase_swap - apr_level_soa(j)= apr_swap + if (use_apr) apr_level_soa(j)= apr_swap i = i + 1 j = j - 1 diff --git a/src/main/memory.f90 b/src/main/memory.f90 index b20dae9f4..809c17221 100644 --- a/src/main/memory.f90 +++ b/src/main/memory.f90 @@ -74,8 +74,8 @@ subroutine allocate_memory(ntot, part_only) endif if (nbytes_allocated > 0.0) then - call warning('memory', 'Attempting to allocate memory, but memory is already allocated. & - & Deallocating and then allocating again.') + call warning('memory', 'Attempting to allocate memory, but memory is already allocated.'// & + 'Deallocating and then allocating again.') call deallocate_memory(part_only=part_only_) endif diff --git a/src/main/part.F90 b/src/main/part.F90 index 936d0d3d1..6f7655daa 100644 --- a/src/main/part.F90 +++ b/src/main/part.F90 @@ -663,7 +663,7 @@ subroutine init_part ndustsmall = 0 ndustlarge = 0 if (lightcurve) luminosity = 0. - apr_level = 1 ! this is reset if the simulation is to derefine + if (use_apr) apr_level = 1 ! this is reset if the simulation is to derefine if (do_radiation) then rad(:,:) = 0. radprop(:,:) = 0. @@ -1249,9 +1249,7 @@ subroutine copy_particle(src,dst,new_part) dustfrac(:,dst) = dustfrac(:,src) dustevol(:,dst) = dustevol(:,src) endif - if (use_apr) then - apr_level(dst) = apr_level(src) - endif + if (use_apr) apr_level(dst) = apr_level(src) if (maxp_h2==maxp .or. maxp_krome==maxp) abundance(:,dst) = abundance(:,src) eos_vars(:,dst) = eos_vars(:,src) if (store_dust_temperature) dust_temp(dst) = dust_temp(src) diff --git a/src/main/readwrite_dumps_fortran.f90 b/src/main/readwrite_dumps_fortran.f90 index 002645f4c..4496e76d2 100644 --- a/src/main/readwrite_dumps_fortran.f90 +++ b/src/main/readwrite_dumps_fortran.f90 @@ -982,7 +982,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto use dump_utils, only:read_array,match_tag use dim, only:use_dust,h2chemistry,maxalpha,maxp,gravity,maxgrav,maxvxyzu,do_nucleation, & use_dustgrowth,maxdusttypes,ndivcurlv,maxphase,gr,store_dust_temperature,& - ind_timesteps,use_krome,use_apr,store_ll_ptmass + ind_timesteps,use_krome,use_apr,store_ll_ptmass,mhd use part, only:xyzh,xyzh_label,vxyzu,vxyzu_label,dustfrac,dustfrac_label,abundance,abundance_label, & alphaind,poten,xyzmh_ptmass,xyzmh_ptmass_label,vxyz_ptmass,vxyz_ptmass_label,linklist_ptmass, & Bevol,Bxyz,Bxyz_label,nabundances,iphase,idust, & @@ -1140,8 +1140,10 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto end select select case(iarr) ! MHD arrays can either be in block 1 or block 4 case(1,4) - call read_array(Bxyz,Bxyz_label,got_Bxyz,ik,i1,i2,noffset,idisk1,tag,match,ierr) - call read_array(Bevol(4,:),'psi',got_psi,ik,i1,i2,noffset,idisk1,tag,match,ierr) + if (mhd) then + call read_array(Bxyz,Bxyz_label,got_Bxyz,ik,i1,i2,noffset,idisk1,tag,match,ierr) + call read_array(Bevol(4,:),'psi',got_psi,ik,i1,i2,noffset,idisk1,tag,match,ierr) + endif end select if (.not.match) then !write(*,*) 'skipping '//trim(tag) diff --git a/src/tests/test_radiation.f90 b/src/tests/test_radiation.f90 index 36c299cfd..70e356d4b 100644 --- a/src/tests/test_radiation.f90 +++ b/src/tests/test_radiation.f90 @@ -105,7 +105,7 @@ subroutine test_exchange_terms(ntests,npass,use_implicit) real :: dt,t,physrho,rhoi,maxt,laste integer :: i,nerr(1),ndiff(1),ncheck,ierrmax,ierr,itest integer(kind=8) :: nptot - logical, parameter :: write_output = .true. + logical, parameter :: write_output = .false. character(len=12) :: string,filestr call init_part() From 9668c30da2a7f3ecd08f5ef75b6d36ab269ef5f2 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 18 Oct 2024 18:13:59 +1100 Subject: [PATCH 080/134] (read_dump) trying to fix ifort memory issue --- src/main/readwrite_dumps_fortran.f90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/main/readwrite_dumps_fortran.f90 b/src/main/readwrite_dumps_fortran.f90 index 4496e76d2..5d6ccf906 100644 --- a/src/main/readwrite_dumps_fortran.f90 +++ b/src/main/readwrite_dumps_fortran.f90 @@ -1142,7 +1142,8 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto case(1,4) if (mhd) then call read_array(Bxyz,Bxyz_label,got_Bxyz,ik,i1,i2,noffset,idisk1,tag,match,ierr) - call read_array(Bevol(4,:),'psi',got_psi,ik,i1,i2,noffset,idisk1,tag,match,ierr) + call read_array(tmparray,'psi',got_psi,ik,i1,i2,noffset,idisk1,tag,match,ierr) + Bevol(4,i1:i2) = tmparray(i1:i2) endif end select if (.not.match) then From 364afe7b2d38963112cbaa2ccbe69e7d7e5e6b36 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 18 Oct 2024 18:21:34 +1100 Subject: [PATCH 081/134] (read_dump) trying to fix ifort memory issue --- src/main/readwrite_dumps_fortran.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/readwrite_dumps_fortran.f90 b/src/main/readwrite_dumps_fortran.f90 index 5d6ccf906..80e5b7d75 100644 --- a/src/main/readwrite_dumps_fortran.f90 +++ b/src/main/readwrite_dumps_fortran.f90 @@ -1047,7 +1047,7 @@ subroutine read_phantom_arrays(i1,i2,noffset,narraylengths,nums,npartread,nparto got_apr_level = .false. ndustfraci = 0 - if (use_dust) allocate(tmparray(size(dustfrac,2))) + if (use_dust .or. mhd) allocate(tmparray(max(size(dustfrac,2),size(Bevol,2)))) over_arraylengths: do iarr=1,narraylengths do k=1,ndatatypes From 376edba38d5c10ed2a0bbb123e8bd6d405cb0326 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 18 Oct 2024 21:29:58 +1100 Subject: [PATCH 082/134] (setstar) fix issues with DEBUG=yes --- src/main/cons2prim.f90 | 1 - src/main/utils_sort.f90 | 2 +- src/setup/set_star.f90 | 4 +++- src/tests/test_rwdump.F90 | 6 +++++- src/tests/test_setstar.f90 | 12 +++++++----- 5 files changed, 16 insertions(+), 9 deletions(-) diff --git a/src/main/cons2prim.f90 b/src/main/cons2prim.f90 index 729d22f9f..700734b1f 100644 --- a/src/main/cons2prim.f90 +++ b/src/main/cons2prim.f90 @@ -307,7 +307,6 @@ subroutine cons2prim_everything(npart,xyzh,vxyzu,dvdx,rad,eos_vars,radprop,& uui = vxyzu(4,i) if (uui < 0.) then call warning('cons2prim','Internal energy < 0',i,'u',uui) - print*,'apr',apr_level(i) endif call equationofstate(ieos,p_on_rhogas,spsound,rhogas,xi,yi,zi,temperaturei,eni=uui,& gamma_local=gammai,mu_local=mui,Xlocal=X_i,Zlocal=Z_i,isionised=isionised(i)) diff --git a/src/main/utils_sort.f90 b/src/main/utils_sort.f90 index 38226e4df..0ba6429a8 100644 --- a/src/main/utils_sort.f90 +++ b/src/main/utils_sort.f90 @@ -635,7 +635,7 @@ subroutine find_rank(npart,func,xyzh,ranki) do i=2,npart ! Loop over ranks sorted by indexxfunc j = iorder(i) k = iorder(i-1) - if (func(xyzh(:,j))/func(xyzh(:,k)) - 1. > min_diff) then ! If particles have distinct radii + if (abs(func(xyzh(:,j)) - func(xyzh(:,k))) > min_diff) then ! If particles have distinct radii ranki(j) = i else ranki(j) = ranki(k) ! Else, give same ranks diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index 614cebe5f..1ab7c0230 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -129,7 +129,7 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& use centreofmass, only:reset_centreofmass use dim, only:do_radiation,gr,gravity,maxvxyzu use io, only:fatal,error,warning - use eos, only:eos_outputs_mu + use eos, only:eos_outputs_mu,polyk_eos=>polyk use setstar_utils, only:set_stellar_core,read_star_profile,set_star_density, & set_star_composition,set_star_thermalenergy,& write_kepler_comp @@ -194,6 +194,7 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& star%isoftcore,star%isofteningopt,star%rcore,star%mcore,& star%hsoft,star%outputfilename,composition,& comp_label,ncols_compo) + ! ! set up particles to represent the desired stellar profile ! @@ -242,6 +243,7 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& ! if (relax) then if (reduceall_mpi('+',npart)==npart) then + polyk_eos = polyk call relax_star(npts,den,pres,r,npart,xyzh,use_var_comp,Xfrac,Yfrac,& mu,ierr_relax,npin=npart_old,label=star%label,& write_dumps=write_dumps,density_error=rmserr,energy_error=en_err) diff --git a/src/tests/test_rwdump.F90 b/src/tests/test_rwdump.F90 index febdb7eb0..509de2039 100644 --- a/src/tests/test_rwdump.F90 +++ b/src/tests/test_rwdump.F90 @@ -58,6 +58,7 @@ subroutine test_rwdump(ntests,npass) real :: xminwas,xmaxwas,yminwas,ymaxwas,zminwas,zmaxwas logical :: test_speed real(kind=4) :: t1 + real, allocatable :: tmparray(:) if (id==master) write(*,"(/,a,/)") '--> TESTING READ/WRITE from dump file' test_speed = .false. @@ -316,7 +317,10 @@ subroutine test_rwdump(ntests,npass) if (id==master) write(*,"(/,a)") '--> checking read of single array from file' xyzh(2,:) = 0. nfailed = 0 - call read_array_from_file(idisk1,'test.dump','y',xyzh(1,:),ierr) + allocate(tmparray(size(xyzh,dim=2))) + call read_array_from_file(idisk1,'test.dump','y',tmparray,ierr) + xyzh(1,:) = tmparray + deallocate(tmparray) call checkval(ierr,0,0,nfailed(1),'error flag') call checkval(npart,xyzh(1,:),2.,tiny(xyzh),nfailed(2),'y') ntests = ntests + 1 diff --git a/src/tests/test_setstar.f90 b/src/tests/test_setstar.f90 index 66318cc76..f9474ca05 100644 --- a/src/tests/test_setstar.f90 +++ b/src/tests/test_setstar.f90 @@ -85,8 +85,7 @@ subroutine test_get_mass_coord(ntests,npass) call update_test_scores(ntests,nfail,npass) ! check that the mass ranking is correct - ncheck = 0 - nfail = 0 + ncheck = 0; nfail = 0; errmax = 0. do i=i1+1,np call checkvalbuf(mass_enclosed_r(i-i1),(i-i1-1)*massoftype(igas),& tol,'m(x) for particles in x=[0,1]',nfail(1),ncheck,errmax) @@ -106,7 +105,9 @@ subroutine test_get_mass_coord(ntests,npass) ! works only for equal mass particles ! mass_enclosed_r = mass_enclosed_r / ((np-i1)*massoftype(igas)) ! make it a mass fraction - call find_rank(np-i1,r2func,xyzh(1:3,i1+1:np),iorder) + call find_rank(np-i1,r2func,xyzh(:,i1+1:np),iorder) + + ncheck = 0; nfail = 0; errmax = 0. do i=i1+1,np massri = real(iorder(i-i1)-1) / real(np-i1) call checkvalbuf(mass_enclosed_r(i-i1),massri,tol,'m( Date: Fri, 18 Oct 2024 21:49:13 +1100 Subject: [PATCH 083/134] (test_radiation) bug fix with uninitialised variable in radiation test --- src/main/radiation_implicit.f90 | 2 +- src/tests/test_radiation.f90 | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/main/radiation_implicit.f90 b/src/main/radiation_implicit.f90 index 5937e0efb..0a79918d8 100644 --- a/src/main/radiation_implicit.f90 +++ b/src/main/radiation_implicit.f90 @@ -870,7 +870,7 @@ subroutine update_gas_radiation_energy(ivar,vari,npart,ncompactlocal,& - dti*h2form + dti*dust_term) + dti*diffusion_numerator*betaval & + stellarradiation*betaval - (chival-1.)*pcoleni - if (u1term > 0. .and. u0term > 0. .or. u1term < 0. .and. u0term < 0.) then + if ((u1term > 0. .and. u0term > 0. .or. u1term < 0. .and. u0term < 0.) .or. isnan(u0term)) then !$omp critical(quart) print *,"ngs ",u4term,u1term,u0term,betaval,chival,gammaval print *," ",EU0(4,i),rhoi,dti diff --git a/src/tests/test_radiation.f90 b/src/tests/test_radiation.f90 index 70e356d4b..d13b5a249 100644 --- a/src/tests/test_radiation.f90 +++ b/src/tests/test_radiation.f90 @@ -89,7 +89,7 @@ subroutine test_exchange_terms(ntests,npass,use_implicit) use io, only:iverbose use part, only:init_part,npart,rhoh,xyzh,fxyzu,vxyzu,massoftype,igas,& iphase,maxphase,isetphase,rhoh,drad,& - npartoftype,rad,radprop,maxvxyzu + npartoftype,rad,radprop,maxvxyzu,luminosity use kernel, only:hfact_default use unifdis, only:set_unifdis use eos, only:gmw,gamma,polyk,iopacity_type @@ -142,7 +142,6 @@ subroutine test_exchange_terms(ntests,npass,use_implicit) pmassi = massoftype(igas) if (use_implicit) call set_linklist(npart,npart,xyzh,vxyzu) - ! ! first version of the test: set gas temperature high and radiation temperature low ! so that gas cools towards radiation temperature (itest=1) @@ -161,6 +160,7 @@ subroutine test_exchange_terms(ntests,npass,use_implicit) endif vxyzu(4,i) = vxyzu(4,i)/rhoi fxyzu(4,i) = 0. + luminosity(i) = 0. enddo if (write_output) then From 56cacf707b73cd4367ca1b3392908b99d786e3aa Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 21 Oct 2024 08:17:06 +1100 Subject: [PATCH 084/134] (set_star) pass npartoftype to shift_star via interface instead of via module; adjust subroutine calls to account for this --- src/setup/set_star.f90 | 15 ++++++++------- src/setup/setup_binary.f90 | 2 +- src/setup/setup_grdisc.F90 | 3 ++- src/setup/setup_grtde.f90 | 2 +- 4 files changed, 12 insertions(+), 10 deletions(-) diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index c8a5f5ec5..94e719333 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -400,10 +400,11 @@ end subroutine set_stars ! shift star to the desired position and velocity !+ !----------------------------------------------------------------------- -subroutine shift_star(npart,xyz,vxyz,x0,v0,itype,corotate) - use part, only:get_particle_type,set_particle_type,igas,npartoftype +subroutine shift_star(npart,npartoftype,xyz,vxyz,x0,v0,itype,corotate) + use part, only:get_particle_type,set_particle_type,igas use vectorutils, only:cross_product3D - integer, intent(in) :: npart + integer, intent(in) :: npart + integer, intent(inout) :: npartoftype(:) real, intent(inout) :: xyz(:,:),vxyz(:,:) real, intent(in) :: x0(3),v0(3) integer, intent(in), optional :: itype @@ -434,7 +435,7 @@ subroutine shift_star(npart,xyz,vxyz,x0,v0,itype,corotate) if (mytype /= itype+istar_offset) cycle over_parts ! reset type back to gas call set_particle_type(i,igas) - npartoftype(itype+istar_offset) = npartoftype(itype+istar_offset) - 1 + npartoftype(mytype) = npartoftype(mytype) - 1 npartoftype(igas) = npartoftype(igas) + 1 endif xyz(1:3,i) = xyz(1:3,i) + x0(:) @@ -453,13 +454,13 @@ end subroutine shift_star !+ !----------------------------------------------------------------------- subroutine shift_stars(nstar,star,xyzmh_ptmass_in,vxyz_ptmass_in,& - xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npart,nptmass,corotate) + xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npart,npartoftype,nptmass,corotate) integer, intent(in) :: nstar,npart type(star_t), intent(in) :: star(nstar) real, intent(inout) :: xyzh(:,:),vxyzu(:,:) real, intent(in) :: xyzmh_ptmass_in(:,:),vxyz_ptmass_in(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) - integer, intent(inout) :: nptmass + integer, intent(inout) :: nptmass,npartoftype(:) logical, intent(in), optional :: corotate integer :: i logical :: do_corotate @@ -469,7 +470,7 @@ subroutine shift_stars(nstar,star,xyzmh_ptmass_in,vxyz_ptmass_in,& do i=1,min(nstar,size(xyzmh_ptmass_in(1,:))) if (star(i)%iprofile > 0) then - call shift_star(npart,xyzh,vxyzu,x0=xyzmh_ptmass_in(1:3,i),& + call shift_star(npart,npartoftype,xyzh,vxyzu,x0=xyzmh_ptmass_in(1:3,i),& v0=vxyz_ptmass_in(1:3,i),itype=i,corotate=do_corotate) else nptmass = nptmass + 1 diff --git a/src/setup/setup_binary.f90 b/src/setup/setup_binary.f90 index 0b6c87bd5..f66acfae9 100644 --- a/src/setup/setup_binary.f90 +++ b/src/setup/setup_binary.f90 @@ -136,7 +136,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& !--place stars into orbit, or add real sink particles if iprofile=0 ! call shift_stars(nstar,star,xyzmh_ptmass_in,vxyz_ptmass_in,xyzh,vxyzu,& - xyzmh_ptmass,vxyz_ptmass,npart,nptmass,corotate=add_spin) + xyzmh_ptmass,vxyz_ptmass,npart,npartoftype,nptmass,corotate=add_spin) ! !--restore options ! diff --git a/src/setup/setup_grdisc.F90 b/src/setup/setup_grdisc.F90 index 2ae3e5427..73d794714 100644 --- a/src/setup/setup_grdisc.F90 +++ b/src/setup/setup_grdisc.F90 @@ -227,7 +227,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! shift the star to the position of the second body if (star(i)%iprofile > 0) then - call shift_star(npart,xyzh,vxyzu,x0=xyzmh_ptmass_in(:,2),v0=vxyz_ptmass_in(:,2),itype=i) + call shift_star(npart,npartoftype,xyzh,vxyzu,& + x0=xyzmh_ptmass_in(:,2),v0=vxyz_ptmass_in(:,2),itype=i) else nptmass = nptmass + 1 xyzmh_ptmass(:,nptmass) = xyzmh_ptmass_in(:,2) diff --git a/src/setup/setup_grtde.f90 b/src/setup/setup_grtde.f90 index 65df28533..475989343 100644 --- a/src/setup/setup_grtde.f90 +++ b/src/setup/setup_grtde.f90 @@ -216,7 +216,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, print "(a,3f10.3,/)",' Pericentre = ',rp endif - call shift_star(npart,xyzh,vxyzu,x0=xyzstar,v0=vxyzstar) + call shift_star(npart,npartoftype,xyzh,vxyzu,x0=xyzstar,v0=vxyzstar) if (id==master) print "(/,a,i10,/)",' Number of particles setup = ',npart From 55eff86981b9b03eacf017734092a0388e73cd61 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Mon, 21 Oct 2024 16:10:56 +0100 Subject: [PATCH 085/134] Edits to enable blob setup to build --- src/main/cooling_radapprox.f90 | 26 ++++++++++++++++---------- src/main/dens.F90 | 18 +++++++++++------- src/main/eos_stamatellos.f90 | 6 ++++-- src/main/radiation_utils.f90 | 6 ++++-- src/utils/analysis_disc_stresses.f90 | 12 ++++++------ 5 files changed, 41 insertions(+), 27 deletions(-) diff --git a/src/main/cooling_radapprox.f90 b/src/main/cooling_radapprox.f90 index 89c563a71..f55707002 100644 --- a/src/main/cooling_radapprox.f90 +++ b/src/main/cooling_radapprox.f90 @@ -77,7 +77,7 @@ subroutine radcool_update_energ(i,xi,yi,zi,rhoi,ui,Tfloor,dt,dudti_cool) real,intent(out)::dudti_cool real :: coldensi,kappaBari,kappaParti,ri2 real :: gmwi,Tmini4,Ti,dudti_rad,Teqi,Hstam,HLom,du_tot - real :: cs2,Om2,Hmod2 + real :: cs2,Om2,Hmod2,rhoi_cgs,ui_cgs real :: opaci,ueqi,umini,tthermi,poti,presi,Hcomb,du_FLDi coldensi = huge(coldensi) @@ -99,7 +99,9 @@ subroutine radcool_update_energ(i,xi,yi,zi,rhoi,ui,Tfloor,dt,dudti_cool) endif ! get opacities & Ti for ui - call getopac_opdep(ui*unit_ergg,rhoi*unit_density,kappaBari,kappaParti,& + ui_cgs = ui*unit_ergg + rhoi_cgs = rhoi*unit_density + call getopac_opdep(ui_cgs,rhoi_cgs,kappaBari,kappaParti,& Ti,gmwi) presi = kb_on_mh*rhoi*unit_density*Ti/gmwi ! cgs presi = presi/unit_pressure !code units @@ -146,7 +148,7 @@ subroutine radcool_update_energ(i,xi,yi,zi,rhoi,ui,Tfloor,dt,dudti_cool) Tmini4 = Tfloor**4d0 endif - call getintenerg_opdep(Tmini4**(1.0/4.0),rhoi*unit_density,umini) + call getintenerg_opdep(Tmini4**(1.0/4.0),rhoi_cgs,umini) umini = umini/unit_ergg opaci = (coldensi**2d0)*kappaBari + (1.d0/kappaParti) ! physical units @@ -195,7 +197,8 @@ subroutine radcool_update_energ(i,xi,yi,zi,rhoi,ui,Tfloor,dt,dudti_cool) "Ti=", Ti, "poti=",poti, "rhoi=", rhoi endif - call getintenerg_opdep(Teqi,rhoi*unit_density,ueqi) + rhoi_cgs = rhoi*unit_density + call getintenerg_opdep(Teqi,rhoi_cgs,ueqi) ueqi = ueqi/unit_ergg ! calculate thermalization timescale @@ -248,7 +251,7 @@ subroutine radcool_update_energ_loop(dtsph,npart,xyzh,energ,dudt_sph,Tfloor) real,intent(inout) :: energ(:),dudt_sph(:) real :: ui,rhoi,coldensi,kappaBari,kappaParti,ri2,dti real :: gmwi,Tmini4,Ti,dudti_rad,Teqi,Hstam,HLom,du_tot - real :: cs2,Om2,Hmod2 + real :: cs2,Om2,Hmod2,ui_cgs,rhoi_cgs real :: opaci,ueqi,umini,tthermi,poti,presi,Hcomb,du_FLDi integer :: i,ratefile,n_uevo @@ -262,8 +265,8 @@ subroutine radcool_update_energ_loop(dtsph,npart,xyzh,energ,dudt_sph,Tfloor) !$omp shared(isink_star,doFLD,ttherm_store,teqi_store,od_method,unit_pressure,ratefile) & !$omp shared(opac_store,Tfloor,dtsph,dudt_sph,utime,udist,umass,unit_ergg,gradP_cool,Lstar) & !$omp private(i,poti,du_FLDi,ui,rhoi,ri2,coldensi,kappaBari,Ti,iphase) & - !$omp private(kappaParti,gmwi,Tmini4,dudti_rad,Teqi,Hstam,HLom,du_tot) & - !$omp private(cs2,Om2,Hmod2,opaci,ueqi,umini,tthermi,presi,Hcomb,dti) & + !$omp private(kappaParti,gmwi,Tmini4,dudti_rad,Teqi,Hstam,HLom,du_tot,ui_cgs) & + !$omp private(cs2,Om2,Hmod2,opaci,ueqi,umini,tthermi,presi,Hcomb,dti,rhoi_cgs) & !$omp shared(maxp,maxphase,ibin) reduction(+:n_uevo) overpart: do i=1,npart @@ -292,7 +295,9 @@ subroutine radcool_update_energ_loop(dtsph,npart,xyzh,energ,dudt_sph,Tfloor) endif ! get opacities & Ti for ui - call getopac_opdep(ui*unit_ergg,rhoi*unit_density,kappaBari,kappaParti,& + ui_cgs = ui*unit_ergg + rhoi_cgs = rhoi*unit_density + call getopac_opdep(ui_cgs,rhoi_cgs,kappaBari,kappaParti,& Ti,gmwi) presi = kb_on_mh*rhoi*unit_density*Ti/gmwi ! cgs presi = presi/unit_pressure !code units @@ -377,10 +382,11 @@ subroutine radcool_update_energ_loop(dtsph,npart,xyzh,energ,dudt_sph,Tfloor) "Ti=", Ti, "poti=",poti, "rhoi=", rhoi endif - call getintenerg_opdep(Teqi,rhoi*unit_density,ueqi) + rhoi_cgs = rhoi*unit_density + call getintenerg_opdep(Teqi,rhoi_cgs,ueqi) ueqi = ueqi/unit_ergg - call getintenerg_opdep(Tmini4**(1.0/4.0),rhoi*unit_density,umini) + call getintenerg_opdep(Tmini4**(1.0/4.0),rhoi_cgs,umini) umini = umini/unit_ergg ! calculate thermalization timescale diff --git a/src/main/dens.F90 b/src/main/dens.F90 index e6fbd2801..b861cb2d8 100644 --- a/src/main/dens.F90 +++ b/src/main/dens.F90 @@ -302,6 +302,7 @@ subroutine densityiterate(icall,npart,nactive,xyzh,vxyzu,divcurlv,divcurlB,Bevol !$omp reduction(max:rhomax) & !$omp private(i) + call init_cell_exchange(xrecvbuf,irequestrecv,thread_complete,ncomplete_mpi,mpitype) !$omp master @@ -1689,14 +1690,14 @@ subroutine calc_lambda_cell(cell,listneigh,nneigh,xyzh,xyzcache,vxyzu,iphase,gra integer :: icell,i,iamtypei,iamtypej,j,n logical :: iactivei,iamgasi,iamdusti,ignoreself logical :: iactivej,iamgasj,iamdustj - real(kind=8) :: hi,hi1,hi21,hi31,hi41 - real :: rhoi,rho1i,dhdrhoi,pmassi,kappabari,kappaparti,Ti,gmwi + real(kind=8) :: hi1,hi21,hi31,hi41,hj1,hj21 + real :: hi,hj,rhoi,rho1i,dhdrhoi,pmassi,kappabari,kappaparti,Ti,gmwi real :: xj,yj,zj,dx,dy,dz - real :: rij2,rij,q2i,qi,hj1,hj,hj21,q2j + real :: rij2,rij,q2i,qi,q2j real :: wabi,grkerni,gradhi,wkerni,dwkerni real :: pmassj,rhoj,rho1j,dhdrhoj,kappabarj,kappaPartj,Tj,gmwj real :: uradi,dradi,dradxi,dradyi,dradzi,runix,runiy,runiz - real :: dT4,R_rad + real :: dT4,R_rad,u_cgs,rho_cgs integer :: ngradh_err ngradh_err = 0 @@ -1735,8 +1736,9 @@ subroutine calc_lambda_cell(cell,listneigh,nneigh,xyzh,xyzcache,vxyzu,iphase,gra print *, "u=0 in FLD calc", vxyzu(4,i), i,rhoi*unit_density,Ti,& cell%xpartvec(ixi,icell),cell%xpartvec(iyi,icell) endif - call getopac_opdep(vxyzu(4,i)*unit_ergg,rhoi*unit_density,kappabari, & - kappaparti,Ti,gmwi) + u_cgs = vxyzu(4,i)*unit_ergg + rho_cgs = rhoi*unit_density + call getopac_opdep(u_cgs,rho_cgs,kappabari,kappaparti,Ti,gmwi) loop_over_neighbours: do n=1,nneigh j = abs(listneigh(n)) @@ -1791,7 +1793,9 @@ subroutine calc_lambda_cell(cell,listneigh,nneigh,xyzh,xyzcache,vxyzu,iphase,gra dwkerni = grkerni*cnormk*hi21*hi21*gradh(1,i) pmassj = massoftype(iamtypej) call rhoanddhdrho(hj,hj1,rhoj,rho1j,dhdrhoj,pmassj) - call getopac_opdep(vxyzu(4,j)*unit_ergg,rhoj*unit_density,& + u_cgs = vxyzu(4,j)*unit_ergg + rho_cgs = rhoj*unit_density + call getopac_opdep(u_cgs,rho_cgs,& kappaBarj,kappaPartj,Tj,gmwj) uradi = uradi + get_radconst_code()*(Tj**4.0d0)*wkerni*pmassj/rhoj diff --git a/src/main/eos_stamatellos.f90 b/src/main/eos_stamatellos.f90 index df4239ba4..84ec8148e 100644 --- a/src/main/eos_stamatellos.f90 +++ b/src/main/eos_stamatellos.f90 @@ -283,13 +283,15 @@ subroutine get_k_fld(rhoi,eni,i,ki,Ti) use units, only:unit_density,unit_ergg,unit_opacity,get_radconst_code real,intent(in) :: rhoi,eni integer,intent(in) :: i - real :: kappaBar,gmwi,kappaPart + real :: kappaBar,gmwi,kappaPart,eni_ergg,rhoi_g real,intent(out) :: ki,Ti if (lambda_FLD(i) == 0d0) then ki = 0. else - call getopac_opdep(eni*unit_ergg,rhoi*unit_density,kappaBar,kappaPart,Ti,gmwi) + eni_ergg = eni*unit_ergg + rhoi_g = rhoi*unit_density + call getopac_opdep(eni_ergg,rhoi_g,kappaBar,kappaPart,Ti,gmwi) kappaPart = kappaPart/unit_opacity ! steboltz constant = 4pi/c * arad ki = 16d0*(fourpi/c)*get_radconst_code()*lambda_FLD(i)*Ti**3 /rhoi/kappaPart diff --git a/src/main/radiation_utils.f90 b/src/main/radiation_utils.f90 index 6197de6cb..a93458977 100644 --- a/src/main/radiation_utils.f90 +++ b/src/main/radiation_utils.f90 @@ -419,7 +419,7 @@ subroutine get_opacity(opacity_type,density,temperature,kappa,u) real, intent(in), optional :: u real, intent(out) :: kappa integer, intent(in) :: opacity_type - real :: kapt,kapr,rho_cgs,Ti,gmwi,kapBar,kappaPart + real :: kapt,kapr,rho_cgs,Ti,gmwi,kapBar,kappaPart,u_cgs select case(opacity_type) case(1) @@ -440,7 +440,9 @@ subroutine get_opacity(opacity_type,density,temperature,kappa,u) ! ! opacity for Stamatellos/Lombardi EOS ! - call getopac_opdep(u*unit_ergg,density*unit_density,kapBar,kappaPart,Ti,gmwi) + rho_cgs = density*unit_density + u_cgs = u*unit_ergg + call getopac_opdep(u_cgs,rho_cgs,kapBar,kappaPart,Ti,gmwi) kappa = kappaPart/unit_opacity case default ! diff --git a/src/utils/analysis_disc_stresses.f90 b/src/utils/analysis_disc_stresses.f90 index 211530826..ea1f79c52 100644 --- a/src/utils/analysis_disc_stresses.f90 +++ b/src/utils/analysis_disc_stresses.f90 @@ -35,7 +35,7 @@ module analysis real, allocatable,dimension(:) :: H, toomre_q,epicyc,part_scaleheight real, allocatable,dimension(:) :: alpha_reyn,alpha_grav,alpha_mag,alpha_art real, allocatable,dimension(:) :: rpart,phipart,vrpart,vphipart, gr,gphi,Br,Bphi - real, allocatable,dimension(:,:) :: gravxyz + real, allocatable,dimension(:,:) :: gravxyz,zsetgas logical :: write_neighbour_list = .true. ! Write the neighbour list to file, if true @@ -356,7 +356,7 @@ end subroutine transform_to_cylindrical !+ !--------------------------------------------------------------- -subroutine radial_binning(npart,xyzh,vxyzu,pmass) +subroutine radial_binning(npart,xyzh,vxyzu,pmass,eos_vars) use physcon, only:pi use eos, only:get_spsound,ieos use part, only:rhoh,isdead_or_accreted @@ -365,7 +365,7 @@ subroutine radial_binning(npart,xyzh,vxyzu,pmass) real,intent(in) :: pmass real,intent(in) :: xyzh(:,:),vxyzu(:,:),eos_vars(:,:) - integer :: ibin,ipart,nbinned + integer :: ibin,ipart,nbinned,iallocerr real :: area,csi print '(a,I4)', 'Carrying out radial binning, number of bins: ',nbins @@ -464,8 +464,8 @@ subroutine calc_stresses(npart,xyzh,vxyzu,pmass) use physcon, only: pi,gg,kb_on_mh use units, only: print_units, umass,udist,utime,unit_velocity,unit_density,unit_Bfield use dim, only: gravity - use part, only: mhd,rhoh,alphaind,eos_vars,imu,itemp - use eos, only: gamma,ieos + use part, only: mhd,rhoh,alphaind,imu,itemp + use eos, only: ieos implicit none @@ -500,7 +500,7 @@ subroutine calc_stresses(npart,xyzh,vxyzu,pmass) sigma(:) = sigma(:)*umass/(udist*udist) if (ieos /= 21) then - csbin(:) = csbin(:)*unit_velocity + csbin(:) = csbin(:)*unit_velocity endif omega(:) = omega(:)/utime From ff2116db96c36a50fed22f2febd94806aaffb9a2 Mon Sep 17 00:00:00 2001 From: Mike Lau Date: Tue, 29 Oct 2024 12:28:28 +0100 Subject: [PATCH 086/134] fix unresolved merge conflict --- src/utils/moddump_removeparticles_radius.f90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/utils/moddump_removeparticles_radius.f90 b/src/utils/moddump_removeparticles_radius.f90 index 85d68818e..65bad1b90 100644 --- a/src/utils/moddump_removeparticles_radius.f90 +++ b/src/utils/moddump_removeparticles_radius.f90 @@ -17,11 +17,7 @@ module moddump ! :Dependencies: part, prompting ! -<<<<<<< HEAD - use part, only:delete_particles_outside_sphere,delete_particles_inside_radius -======= use part, only:delete_particles_outside_sphere,igas,idust ->>>>>>> e805ed68f91e4a807462a786fb1447b541deb978 use prompting, only:prompt implicit none From dc360c8ec92ec2351fd461248f78cbb5909f6e1c Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 30 Oct 2024 08:48:02 +1100 Subject: [PATCH 087/134] (extern_densprofile) add header to density profile output for ease of plotting --- src/main/extern_densprofile.f90 | 93 ++++++--------------------------- 1 file changed, 17 insertions(+), 76 deletions(-) diff --git a/src/main/extern_densprofile.f90 b/src/main/extern_densprofile.f90 index d8fc59c21..2a78573a6 100644 --- a/src/main/extern_densprofile.f90 +++ b/src/main/extern_densprofile.f90 @@ -41,6 +41,7 @@ module extern_densprofile !+ !---------------------------------------------- subroutine densityprofile_force(xi,yi,zi,fxi,fyi,fzi,phi) + use table_utils, only:yinterp real, intent(in) :: xi, yi, zi real, intent(out) :: fxi, fyi, fzi, phi @@ -58,7 +59,7 @@ subroutine densityprofile_force(xi,yi,zi,fxi,fyi,fzi,phi) if (ri2 >= r2surf) then f = fsurf * (r2surf / ri2)**1.5 else - f = yinterp(ri2, r2tab, ftab, ntab) + f = yinterp(ftab(1:ntab),r2tab(1:ntab),ri2) endif fxi = f * xi @@ -136,13 +137,15 @@ subroutine read_rhotab(filename, rsize, rtab, rhotab, nread, polyk, gamma, rhoc, return endif - ! First line: # K gamma rhoc + ! first line, skip header + read(iunit, *,iostat=ierr) + ! second line: # K gamma rhoc read(iunit, *,iostat=ierr) hash,polyk, gamma, rhoc if (ierr /= 0) then call error('extern_densityprofile','Error reading first line of header from '//trim(filename)) return endif - ! Second line: # nentries (number of r density entries in file) + ! third line: # nentries (number of r density entries in file) read(iunit,*,iostat=ierr) hash,nread if (ierr /= 0) then call error('extern_densityprofile','Error reading second line of header from '//trim(filename)) @@ -180,11 +183,14 @@ subroutine write_rhotab(filename, rtab, rhotab, ntab, polyk, gamma, rhoc, ierr) ierr = 0 open(newunit=iunit,file=filename,action='write',status='replace') + ! write header '# r,density' + write(iunit,"(a)") '# r, density' + ! First line: # K gamma rhoc - write(iunit,*) '# ', polyk, gamma, rhoc + write(iunit,"(a,3(g0,1x))") '# ', polyk, gamma, rhoc ! Second line: # nentries (number of r density entries in file) - write(iunit,*) '# ', ntab + write(iunit,"(a,i0)") '# ', ntab ! Loop over 'n' lines: r and density separated by space do i = 1,ntab @@ -207,82 +213,17 @@ subroutine calc_menc(n, r, rho, menc_out, totmass) r2 = r(1:n)**2 r2rho = r2(1:n) * rho(1:n) - if (.false.) then - ! NB: Ensure that this mass calculation is correct if it is to be used (J. Wurster) - ! Use trapezoid, Simpson's and Simpson's 3/8 for first entries then Simpson's for remaining - ! (trapezoidal term has largest order error: avoid using it as part of sum for later terms) - menc(1) = 0. - menc(2) = (r(2)-r(1)) * (r2rho(1) + r2(2) * rho(2)) / 2. - menc(3) = (r(3)-r(1)) * (r2rho(1) + 4.*r2rho(2) + r2rho(3)) / 6. - menc(4) = (r(4)-r(1)) * (r2rho(1) + 3.*r2rho(2) + 3.*r2rho(3) + r2rho(4)) / 8. - totalmass = menc(1) + menc(2) + menc(3) + menc(4) - do i = 5, n - menc(i) = menc(i-2) + (r2rho(i-2) + 4.*r2rho(i-1) + r2rho(i)) * (r(i) - r(i-2)) / 6. - totalmass = totalmass + menc(i) - enddo - menc(:) = 4.0 * pi * menc(:) - totalmass = 4.0 * pi * totalmass - else - menc(1) = 4.0/3.0*pi*r(1)**3 * rho(1) - do i = 2,n - menc(i) = menc(i-1) + 4.0/3.0*pi*(r(i)**3 - r(i-1)**3) * rho(i) - enddo - totalmass = menc(n) - endif + menc(1) = 4.0/3.0*pi*r(1)**3 * rho(1) + do i = 2,n + menc(i) = menc(i-1) + 4.0/3.0*pi*(r(i)**3 - r(i-1)**3) * rho(i) + enddo + totalmass = menc(n) + if (present(menc_out)) menc_out = menc if (present(totmass)) totmass = totalmass end subroutine calc_menc -! Linear 1D interpolation -real function yinterp(x, xtab, ytab, ntab) - real, intent(in) :: x - real, intent(in) :: ytab(:),xtab(:) - integer, intent(in) :: ntab - - integer :: ibelow, iabove - real :: slope - - yinterp = 0. - if (x <= xtab(1)) then - yinterp = ytab(1) - return - elseif (x >= xtab(ntab)) then - yinterp = ytab(ntab) - return - endif - - ibelow = indexbelow(x, xtab, ntab) - iabove = ibelow + 1 - - slope = (ytab(iabove) - ytab(ibelow)) / (xtab(iabove) - xtab(ibelow)) - yinterp = ytab(ibelow) + (x - xtab(ibelow)) * slope - -end function yinterp - -! Find index below value x in monotomic array xtab -pure integer function indexbelow(x, xtab, ntab) - real, intent(in) :: x - real, intent(in) :: xtab(:) - integer, intent(in) :: ntab - - integer :: ibelow, imid, iabove - - ibelow = 1 - iabove = ntab - do while ((iabove - ibelow) > 1) - imid = (iabove + ibelow) / 2 - if ((x > xtab(imid)) .eqv. (xtab(ntab) > xtab(1))) then - ibelow = imid - else - iabove = imid - endif - enddo - - indexbelow = ibelow - -end function indexbelow - !---------------------------------------------- !+ ! Wrapper to get the density profile (J.Wurster) From 9cb7869dfe26079b30e6448e78d5d6f92a4bfedb Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 30 Oct 2024 08:48:08 +1100 Subject: [PATCH 088/134] (extern_densprofile) add header to density profile output for ease of plotting --- data/neutronstar/ns-rdensity.tab | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/data/neutronstar/ns-rdensity.tab b/data/neutronstar/ns-rdensity.tab index 9e736f9e6..61ab9ef2e 100644 --- a/data/neutronstar/ns-rdensity.tab +++ b/data/neutronstar/ns-rdensity.tab @@ -1,5 +1,6 @@ - # 0.42442000000000002 1.6666700000000001 1.4249734000000001 - # 914 +# r, density +# 0.42442000000000002 1.6666700000000001 1.4249734000000001 +# 914 0.0000000000000000 1.4281200250341688 1.0952902519167577E-003 1.4281143125578766 2.1905805038335154E-003 1.4280971752432505 From 530a6b7292425e5390c5280bf949375677d00c4a Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 30 Oct 2024 08:48:35 +1100 Subject: [PATCH 089/134] (sort) fix warning in sort-by-radius function --- src/main/utils_sort.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/main/utils_sort.f90 b/src/main/utils_sort.f90 index 0ba6429a8..4ffbf6bd3 100644 --- a/src/main/utils_sort.f90 +++ b/src/main/utils_sort.f90 @@ -650,9 +650,9 @@ end subroutine find_rank ! coordinates as input !+ !---------------------------------------------------------------- -subroutine sort_by_radius(n,xyz,iorder,x0) +subroutine sort_by_radius(n,xyzh,iorder,x0) integer, intent(in) :: n - real, intent(in) :: xyz(3,n) + real, intent(in) :: xyzh(4,n) integer, intent(out) :: iorder(n) real, intent(in), optional :: x0(3) @@ -660,7 +660,7 @@ subroutine sort_by_radius(n,xyz,iorder,x0) if (present(x0)) call set_r2func_origin(x0(1),x0(2),x0(3)) ! sort by r^2 using the r2func function - call indexxfunc(n,r2func,xyz,iorder) + call indexxfunc(n,r2func,xyzh,iorder) end subroutine sort_by_radius From 87a099bde77d3e14858d2dad250e52446b15efff Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 30 Oct 2024 09:58:49 +1100 Subject: [PATCH 090/134] (utils_infiles) allow optional default= argument for read_inopt_string --- src/main/utils_infiles.f90 | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/main/utils_infiles.f90 b/src/main/utils_infiles.f90 index 1a5259b6c..8b788ff80 100644 --- a/src/main/utils_infiles.f90 +++ b/src/main/utils_infiles.f90 @@ -528,12 +528,13 @@ end subroutine read_inopt_real ! read a string variable from an input options database !+ !----------------------------------------------------------------- -subroutine read_inopt_string(valstring,tag,db,err,errcount) +subroutine read_inopt_string(valstring,tag,db,err,errcount,default) character(len=*), intent(out) :: valstring character(len=*), intent(in) :: tag type(inopts), allocatable, intent(inout) :: db(:) integer, intent(out), optional :: err integer, intent(inout), optional :: errcount + character(len=*), intent(in), optional :: default integer :: ierr ierr = 0 @@ -546,6 +547,12 @@ subroutine read_inopt_string(valstring,tag,db,err,errcount) if (present(errcount)) then if (ierr /= 0) errcount = errcount + 1 endif + ! default string to use if the string read is blank + if (present(default)) then + if (len_trim(valstring) <= 0) then + valstring = default + endif + endif end subroutine read_inopt_string From 3d5b3b9e59a1562db8bd6da4ee6674f0b64177b9 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 30 Oct 2024 10:01:44 +1100 Subject: [PATCH 091/134] (density_profiles) try to handle the case where stellar radius is unresolved by the grid; adjust dr until resolved --- src/setup/density_profiles.f90 | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/setup/density_profiles.f90 b/src/setup/density_profiles.f90 index b06e9b2f1..6189b73bc 100644 --- a/src/setup/density_profiles.f90 +++ b/src/setup/density_profiles.f90 @@ -163,6 +163,7 @@ subroutine rho_piecewise_polytrope(rtab,rhotab,rhocentre,mstar_in,get_dPdrho,npt lastsign = 1 iterate = .true. bisect = .false. + rtab = 0. ! !--Iterate to get the correct density profile do while ( iterate ) @@ -171,6 +172,10 @@ subroutine rho_piecewise_polytrope(rtab,rhotab,rhocentre,mstar_in,get_dPdrho,npt !--did not complete the profile; reset dr dr = 2.0*dr ierr = 0 + elseif (npts < size(rtab)/4) then + !--profile is unresolved by radial grid, take smaller dr + dr = 0.5*dr + ierr = 0 else call calc_mass_enc(npts,rtab,rhotab,mstar=mstar) !--iterate to get the correct mass @@ -234,6 +239,8 @@ subroutine integrate_rho_profile(rtab,rhotab,rhocentre,get_dPdrho,dr,npts,ierr) i = i + 1 rhotab(i) = rhotab(i-1) + dr*drhodr rtab(i) = rtab(i-1) + dr + if (rhotab(i) < 0.0) exit + dPdrho = get_dPdrho(rhotab(i)) if (i==2) then drhodr = drhodr - fourpi*rhotab(i-1)**2*dr/dPdrho @@ -243,7 +250,6 @@ subroutine integrate_rho_profile(rtab,rhotab,rhocentre,get_dPdrho,dr,npts,ierr) - (dPdrho-dPdrho_prev)/(dr*dPdrho)*drhodr - 2.0*drhodr/rtab(i) ) endif dPdrho_prev = dPdrho - if (rhotab(i) < 0.0) iterate = .false. if (i >=size(rtab)) then ierr = 1 iterate = .false. From b0f68b315ed042adb718704779b260b711b47294 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 30 Oct 2024 10:02:12 +1100 Subject: [PATCH 092/134] (infile) allow eos=9 even if maxvxyzu=4 --- src/main/readwrite_infile.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/readwrite_infile.F90 b/src/main/readwrite_infile.F90 index 1094e6a6a..e173b7fe7 100644 --- a/src/main/readwrite_infile.F90 +++ b/src/main/readwrite_infile.F90 @@ -702,7 +702,7 @@ subroutine read_infile(infile,logfile,evfile,dumpfile) #ifndef MCFOST if (maxvxyzu >= 4 .and. (ieos /= 2 .and. ieos /= 5 .and. ieos /= 4 .and. ieos /= 10 .and. & ieos /=11 .and. ieos /=12 .and. ieos /= 15 .and. ieos /= 16 .and. ieos /= 17 .and. & - ieos /= 20 .and. ieos/=22)) & + ieos /= 20 .and. ieos/=22 .and. ieos /= 9)) & call fatal(label,'only ieos=2 makes sense if storing thermal energy') #endif if (irealvisc < 0 .or. irealvisc > 12) call fatal(label,'invalid setting for physical viscosity') From b78643c9d17ac9014b2b9b2f5d67bde3ccbebdf8 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 30 Oct 2024 10:02:45 +1100 Subject: [PATCH 093/134] (eos) allow import of irecomb from eos module --- src/main/eos.f90 | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/main/eos.f90 b/src/main/eos.f90 index 10528d8ca..07e0f7ad9 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -46,8 +46,9 @@ module eos ! eos_stratified, infile_utils, io, mesa_microphysics, part, physcon, ! units ! - use part, only:ien_etotal,ien_entropy,ien_type - use dim, only:gr + use part, only:ien_etotal,ien_entropy,ien_type + use dim, only:gr + use eos_gasradrec, only:irecomb implicit none integer, parameter, public :: maxeos = 22 real, public :: polyk, polyk2, gamma @@ -64,6 +65,8 @@ module eos public :: init_eos,finish_eos,write_options_eos,read_options_eos public :: write_headeropts_eos, read_headeropts_eos + public :: irecomb ! propagated from eos_gasradrec + private integer, public :: ieos = 1 From 77cacb8c4202f27950975fb1781f1b43e98b40dd Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Wed, 30 Oct 2024 10:04:03 +1100 Subject: [PATCH 094/134] (relax_star) bug fixes for relaxation with ieos=9 --- src/setup/relax_star.f90 | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/src/setup/relax_star.f90 b/src/setup/relax_star.f90 index f081f1f4f..c05c2deaa 100644 --- a/src/setup/relax_star.f90 +++ b/src/setup/relax_star.f90 @@ -70,7 +70,7 @@ subroutine relax_star(nt,rho,pr,r,npart,xyzh,use_var_comp,Xfrac,Yfrac,mu,ierr,np use io, only:error,warning,fatal,id,master use fileutils, only:getnextfilename use readwrite_dumps, only:write_fulldump,init_readwrite_dumps - use eos, only:gamma,eos_outputs_mu + use eos, only:gamma,eos_outputs_mu,ieos use physcon, only:pi use options, only:iexternalforce use io_summary, only:summary_initialise @@ -165,9 +165,14 @@ subroutine relax_star(nt,rho,pr,r,npart,xyzh,use_var_comp,Xfrac,Yfrac,mu,ierr,np ! define utherm(r) based on P(r) and rho(r) ! and use this to set the thermal energy of all particles ! - entrop = pr/rho**gamma - utherm = pr/(rho*(gamma-1.)) - if (any(utherm <= 0.)) then + where (rho > 0) + entrop = pr/rho**gamma + utherm = pr/(rho*(gamma-1.)) + elsewhere + entrop = 0. + utherm = 0. + end where + if (any(utherm(1:nt-1) <= 0.)) then call error('relax_star','relax-o-matic needs non-zero pressure array set in order to work') call restore_original_options(i1,npart) ierr = ierr_no_pressure @@ -187,7 +192,7 @@ subroutine relax_star(nt,rho,pr,r,npart,xyzh,use_var_comp,Xfrac,Yfrac,mu,ierr,np ! ! perform sanity checks ! - if (etherm > abs(epot)) then + if (etherm > abs(epot) .and. ieos /= 9) then call error('relax_star','cannot relax star because it is unbound (etherm > epot)') if (id==master) print*,' Etherm = ',etherm,' Epot = ',Epot if (maxvxyzu < 4) print "(/,a,/)",' *** Try compiling with ISOTHERMAL=no instead... ***' @@ -463,7 +468,7 @@ subroutine set_options_for_relaxation(tdyn) ! ! turn on settings appropriate to relaxation ! - if (maxvxyzu >= 4) ieos = 2 + if (maxvxyzu >= 4 .and. ieos /= 9) ieos = 2 if (tdyn > 0.) then idamp = 2 tdyn_s = tdyn*utime From 2ec3ecc5d15adc62412138253708b823d81d57dd Mon Sep 17 00:00:00 2001 From: Alison Young Date: Mon, 4 Nov 2024 10:51:24 +0000 Subject: [PATCH 095/134] Rad approx cooling: changed to update energy during leapfrog integrator. --- src/main/cooling.f90 | 11 +- src/main/cooling_radapprox.f90 | 302 +++++--------------- src/main/dens.F90 | 13 +- src/main/eos.f90 | 1 + src/main/eos_stamatellos.f90 | 9 +- src/main/force.F90 | 17 +- src/main/{mpi_memory.F90 => mpi_memory.f90} | 0 src/main/readwrite_dumps_fortran.f90 | 4 +- src/main/step_leapfrog.F90 | 47 +-- src/main/substepping.F90 | 11 +- 10 files changed, 133 insertions(+), 282 deletions(-) rename src/main/{mpi_memory.F90 => mpi_memory.f90} (100%) diff --git a/src/main/cooling.f90 b/src/main/cooling.f90 index 0bb572586..f7953f911 100644 --- a/src/main/cooling.f90 +++ b/src/main/cooling.f90 @@ -75,7 +75,6 @@ subroutine init_cooling(id,master,iprint,ierr) integer, intent(in) :: id,master,iprint integer, intent(out) :: ierr - logical :: ex cooling_in_step = .true. ierr = 0 @@ -90,8 +89,6 @@ subroutine init_cooling(id,master,iprint,ierr) var='ieos',ival=ieos) if (irealvisc > 0 .and. od_method == 4) call warning('cooling',& 'Using real viscosity will affect optical depth estimate',var='irealvisc',ival=irealvisc) - inquire(file=eos_file,exist=ex) - if (.not. ex ) call fatal('cooling','file not found',var=eos_file) if (ieos == 2) call read_optab(eos_file,ierr) if (ierr > 0) call fatal('cooling','Failed to read EOS file',var='ierr',ival=ierr) call init_star() @@ -132,7 +129,7 @@ end subroutine init_cooling ! !----------------------------------------------------------------------- -subroutine energ_cooling(xi,yi,zi,ui,rho,dt,divv,dudt,Tdust_in,mu_in,gamma_in,K2_in,kappa_in,abund_in,ipart) +subroutine energ_cooling(xi,yi,zi,ui,rho,dt,divv,dudt,Tdust_in,mu_in,gamma_in,K2_in,kappa_in,abund_in,duhydro,ipart) use io, only:fatal use dim, only:nabundances use eos, only:gmw,gamma,ieos,get_temperature_from_u @@ -143,12 +140,12 @@ subroutine energ_cooling(xi,yi,zi,ui,rho,dt,divv,dudt,Tdust_in,mu_in,gamma_in,K2 use cooling_solver, only:energ_cooling_solver use cooling_koyamainutsuka, only:cooling_KoyamaInutsuka_explicit,& cooling_KoyamaInutsuka_implicit - use cooling_radapprox, only:radcool_update_energ + use cooling_radapprox, only:radcool_update_du real(kind=4), intent(in) :: divv ! in code units real, intent(in) :: xi,yi,zi,ui,rho,dt ! in code units real, intent(in), optional :: Tdust_in,mu_in,gamma_in,K2_in,kappa_in ! in cgs - real, intent(in), optional :: abund_in(nabn) + real, intent(in), optional :: abund_in(nabn),duhydro integer,intent(in),optional:: ipart real, intent(out) :: dudt ! in code units real :: mui,gammai,Tgas,Tdust,K2,kappa @@ -187,7 +184,7 @@ subroutine energ_cooling(xi,yi,zi,ui,rho,dt,divv,dudt,Tdust_in,mu_in,gamma_in,K2 case (7) call cooling_Gammie_PL_explicit(xi,yi,zi,ui,dudt) case (9) - call radcool_update_energ(ipart,xi,yi,zi,rho,ui,Tfloor,dt,dudt) + call radcool_update_du(ipart,xi,yi,zi,rho,ui,duhydro,Tfloor) case default call energ_cooling_solver(ui,dudt,rho,dt,mui,gammai,Tdust,K2,kappa) end select diff --git a/src/main/cooling_radapprox.f90 b/src/main/cooling_radapprox.f90 index 0e83f7f81..373f8ddc3 100644 --- a/src/main/cooling_radapprox.f90 +++ b/src/main/cooling_radapprox.f90 @@ -25,8 +25,8 @@ module cooling_radapprox integer :: isink_star ! index of sink to use as illuminating star integer :: od_method = 4 ! default = Modified Lombardi method (Young et al. 2024) integer :: fld_opt = 1 ! by default FLD is switched on - public :: radcool_update_energ,write_options_cooling_radapprox,read_options_cooling_radapprox - public :: init_star, radcool_update_energ_loop + public :: radcool_update_du,write_options_cooling_radapprox,read_options_cooling_radapprox + public :: init_star,radcool_evolve_ui contains @@ -59,22 +59,72 @@ subroutine init_star() "at (xyz)",xyzmh_ptmass(1:3,isink_star)!"as illuminating star." end subroutine init_star +subroutine radcool_evolve_ui(ui,dt,i,Tfloor,h,uout) + use eos_stamatellos, only:ttherm_store,ueqi_store,getintenerg_opdep + use io, only:warning + use units, only:unit_density,unit_ergg + use part, only:rhoh,massoftype,igas + real, intent(inout) :: ui + real, intent(in) :: dt,Tfloor,h + integer,intent(in) :: i + real,optional,intent(out) :: uout + real :: tthermi,ueqi,utemp,ufloor_cgs,rhoi_cgs + real :: expdtonttherm + + tthermi = ttherm_store(i) + ueqi = ueqi_store(i) + utemp = ui + rhoi_cgs = rhoh(h,massoftype(igas))*unit_density + call getintenerg_opdep(Tfloor**(1.0/4.0),rhoi_cgs,ufloor_cgs) + + if (tthermi > epsilon(tthermi) .and. ui /= ueqi) then + if (dt > 0d0) then + ! evolve energy + expdtonttherm = exp(-dt/tthermi) + utemp = ui*expdtonttherm + ueqi*(1.d0-expdtonttherm) + elseif (dt < 0d0) then + ! i.e. for the backwards step in the leapfrog integrator + expdtonttherm = exp(dt/tthermi) + utemp = (ui - ueqi*(1-expdtonttherm))/expdtonttherm + endif + + ! if tthermi ==0 or dt/thermi is neglible then ui doesn't change + if (isnan(utemp) .or. utemp < epsilon(utemp)) then +! print *, "oh no i=",i,"ui=",ui,"tthermi=",tthermi,dt,"ueqi",ueqi,rhoi_cgs + ! print *, exp(-dt/tthermi),1.d0-exp(-dt/tthermi) +! call warning("In radcool_evolve_ui","energ=NaN or 0. ui=",val=utemp) + utemp = ui + endif + endif +!else + ! print *, "no_update", tthermi,dt,ui,ueqi + !endif + if (utemp < ufloor_cgs/unit_ergg) utemp = ufloor_cgs/unit_ergg + if (utemp < 0d0) print *, "ERRRORRR! i=",i, ui,ueqi + + if (present(uout)) then + uout = utemp + else + ui = utemp + endif + +end subroutine radcool_evolve_ui + ! ! Do cooling calculation ! ! update energy to return evolved energy array. Called from substep -subroutine radcool_update_energ(i,xi,yi,zi,rhoi,ui,Tfloor,dt,dudti_cool) +subroutine radcool_update_du(i,xi,yi,zi,rhoi,ui,duhydro,Tfloor) use io, only:warning use physcon, only:steboltz,pi,solarl,Rg,kb_on_mh,piontwo,rpiontwo use units, only:umass,udist,unit_density,unit_ergg,utime,unit_pressure use eos_stamatellos, only:getopac_opdep,getintenerg_opdep,gradP_cool,Gpot_cool,& - duFLD,doFLD,ttherm_store,teqi_store,opac_store,duSPH - use part, only:xyzmh_ptmass,igas + duFLD,doFLD,ttherm_store,ueqi_store,opac_store + use part, only:xyzmh_ptmass,igas,eos_vars,iTemp integer,intent(in) :: i - real,intent(in) :: xi,yi,zi,rhoi,Tfloor - real,intent(in) :: ui,dt - real,intent(out)::dudti_cool + real,intent(in) :: xi,yi,zi,rhoi + real,intent(in) :: ui,duhydro,Tfloor real :: coldensi,kappaBari,kappaParti,ri2 real :: gmwi,Tmini4,Ti,dudti_rad,Teqi,Hstam,HLom,du_tot real :: cs2,Om2,Hmod2,rhoi_cgs,ui_cgs @@ -103,6 +153,7 @@ subroutine radcool_update_energ(i,xi,yi,zi,rhoi,ui,Tfloor,dt,dudti_cool) rhoi_cgs = rhoi*unit_density call getopac_opdep(ui_cgs,rhoi_cgs,kappaBari,kappaParti,& Ti,gmwi) + eos_vars(iTemp,i) = Ti ! save temperature presi = kb_on_mh*rhoi*unit_density*Ti/gmwi ! cgs presi = presi/unit_pressure !code units @@ -156,39 +207,25 @@ subroutine radcool_update_energ(i,xi,yi,zi,rhoi,ui,Tfloor,dt,dudti_cool) dudti_rad = 4.d0*steboltz*(Tmini4 - Ti**4.d0)/opaci/unit_ergg*utime! code units if (doFLD) then - du_tot = duSPH(i) + du_FLDi + du_tot = duhydro + du_FLDi else - du_tot = duSPH(i) - endif - - ! If radiative cooling is negligible compared to hydrodynamical heating - ! don't use this method to update energy, just use hydro du/dt. Does it conserve u alright? - - if (abs(du_tot) > epsilon(du_tot) .and. abs(dudti_rad/du_tot) < dtcool_crit) then - ! print *, "not cooling/heating for r=",sqrt(ri2),".", dudti_rad,& - ! dusph(i) - dudti_cool = du_tot - if ( (dudti_cool*dt + ui) < umini) then - dudti_cool = (umini - ui)/dt - endif - return + du_tot = duhydro endif Teqi = du_tot * opaci*unit_ergg/utime ! physical units Teqi = Teqi/4.d0/steboltz Teqi = Teqi + Tmini4 du_tot = du_tot + dudti_rad + !Check if we need to use the temperature floor if (Teqi < Tmini4) then Teqi = Tmini4**(1.0/4.0) else Teqi = Teqi**(1.0/4.0) endif - teqi_store(i) = Teqi if (Teqi > 9e5) then - print *,"i=",i, "duSPH(i)=", duSPH(i), "duradi=", dudti_rad, "Ti=", Ti, & - "Tmini=", Tmini4**(1.0/4.0),du_tot,Hcomb, "r=",sqrt(ri2), "ui=", ui, & - "dudt_sph * dti=", dusph(i)*dt + print *,"i=",i, "duhydro=", duhydro, "duradi=", dudti_rad, "Ti=", Ti, & + "Tmini=", Tmini4**(1.0/4.0),du_tot,Hcomb, "r=",sqrt(ri2), "ui=", ui elseif (Teqi < epsilon(Teqi)) then print *, "Teqi=0.0", "Tmini4=", Tmini4, "coldensi=", coldensi, "Tfloor=",Tfloor,& "Ti=", Ti, "poti=",poti, "rhoi=", rhoi @@ -200,7 +237,7 @@ subroutine radcool_update_energ(i,xi,yi,zi,rhoi,ui,Tfloor,dt,dudti_cool) rhoi_cgs = rhoi*unit_density call getintenerg_opdep(Teqi,rhoi_cgs,ueqi) ueqi = ueqi/unit_ergg - + ueqi_store(i) = ueqi ! calculate thermalization timescale if ((du_tot) == 0.d0) then tthermi = 0d0 @@ -210,220 +247,19 @@ subroutine radcool_update_energ(i,xi,yi,zi,rhoi,ui,Tfloor,dt,dudti_cool) ttherm_store(i) = tthermi - ! evolve energy - if (tthermi == 0d0) then - dudti_cool = 0d0 ! condition if denominator above is zero - elseif ( (dt/tthermi) < TINY(ui) ) then - dudti_cool = 0d0 - else - dudti_cool = ( ui*exp(-dt/tthermi) + ueqi*(1.d0-exp(-dt/tthermi)) - ui) / dt !code units - endif - if (isnan(dudti_cool)) then + if (isnan(tthermi) .or. isnan(ueqi)) then ! print *, "kappaBari=",kappaBari, "kappaParti=",kappaParti print *, "rhoi=",rhoi*unit_density, "Ti=", Ti, "Teqi=", Teqi print *, "Tmini=",Tmini4**(1.0/4.0), "ri=", ri2**(0.5) - print *, "opaci=",opaci,"coldensi=",coldensi,"dusph(i)",duSPH(i) - print *, "dt=",dt,"tthermi=", tthermi,"umini=", umini + print *, "opaci=",opaci,"coldensi=",coldensi,"duhydro",duhydro + print *, "tthermi=", tthermi,"umini=", umini print *, "dudti_rad=", dudti_rad ,"dudt_fld=",du_fldi,"ueqi=",ueqi,"ui=",ui call warning("In Stamatellos cooling","energ=NaN or 0. ui=",val=ui) stop endif -end subroutine radcool_update_energ - - -! -! Do cooling calculation -! -! update energy to return evolved energy array. Called from evolve.F90 -subroutine radcool_update_energ_loop(dtsph,npart,xyzh,energ,dudt_sph,Tfloor) - use io, only:warning - use physcon, only:steboltz,pi,solarl,Rg,kb_on_mh,piontwo,rpiontwo - use units, only:umass,udist,unit_density,unit_ergg,utime,unit_pressure - use eos_stamatellos, only:getopac_opdep,getintenerg_opdep,gradP_cool,Gpot_cool,& - duFLD,doFLD,ttherm_store,teqi_store,opac_store - use part, only:xyzmh_ptmass,rhoh,massoftype,igas,iactive,isdead_or_accreted - use part, only:iphase,maxphase,maxp,iamtype,ibin - use timestep_ind, only:get_dt - integer,intent(in) :: npart - real,intent(in) :: xyzh(:,:),dtsph,Tfloor - real,intent(inout) :: energ(:),dudt_sph(:) - real :: ui,rhoi,coldensi,kappaBari,kappaParti,ri2,dti - real :: gmwi,Tmini4,Ti,dudti_rad,Teqi,Hstam,HLom,du_tot - real :: cs2,Om2,Hmod2,ui_cgs,rhoi_cgs - real :: opaci,ueqi,umini,tthermi,poti,presi,Hcomb,du_FLDi - integer :: i,ratefile,n_uevo - - coldensi = huge(coldensi) -! write (temp,'(E5.2)') dt - print *, "radcool min/maxGpot", minval(Gpot_cool),maxval(Gpot_cool) - print *, "radcool min/max", minval(gradP_cool),maxval(gradP_cool) - n_uevo = 0 - !$omp parallel do default(none) schedule(runtime) & - !$omp shared(npart,duFLD,xyzh,energ,massoftype,xyzmh_ptmass,unit_density,Gpot_cool) & - !$omp shared(isink_star,doFLD,ttherm_store,teqi_store,od_method,unit_pressure,ratefile) & - !$omp shared(opac_store,Tfloor,dtsph,dudt_sph,utime,udist,umass,unit_ergg,gradP_cool,Lstar) & - !$omp private(i,poti,du_FLDi,ui,rhoi,ri2,coldensi,kappaBari,Ti,iphase) & - !$omp private(kappaParti,gmwi,Tmini4,dudti_rad,Teqi,Hstam,HLom,du_tot,ui_cgs) & - !$omp private(cs2,Om2,Hmod2,opaci,ueqi,umini,tthermi,presi,Hcomb,dti,rhoi_cgs) & - !$omp shared(maxp,maxphase,ibin) reduction(+:n_uevo) - - overpart: do i=1,npart - if (maxphase==maxp) then - if (iamtype(iphase(i)) /= igas) cycle - if (isdead_or_accreted(xyzh(4,i))) cycle - if (.not. iactive(iphase(i)) ) then - n_uevo = n_uevo + 1 - cycle - endif - endif - - dti = get_dt(dtsph,ibin(i)) - poti = Gpot_cool(i) - du_FLDi = duFLD(i) - ui = energ(i) - if (abs(ui) < epsilon(ui)) print *, "ui zero", i - rhoi = rhoh(xyzh(4,i),massoftype(igas)) - - if (isink_star > 0) then - ri2 = (xyzh(1,i)-xyzmh_ptmass(1,isink_star))**2d0 & - + (xyzh(2,i)-xyzmh_ptmass(2,isink_star))**2d0 & - + (xyzh(3,i)-xyzmh_ptmass(3,isink_star))**2d0 - else - ri2 = xyzh(1,i)**2d0 + xyzh(2,i)**2d0 + xyzh(3,i)**2d0 - endif - - ! get opacities & Ti for ui - ui_cgs = ui*unit_ergg - rhoi_cgs = rhoi*unit_density - call getopac_opdep(ui_cgs,rhoi_cgs,kappaBari,kappaParti,& - Ti,gmwi) - presi = kb_on_mh*rhoi*unit_density*Ti/gmwi ! cgs - presi = presi/unit_pressure !code units - - select case (od_method) - case (1) - ! Stamatellos+ 2007 method - coldensi = sqrt(abs(poti*rhoi)/4.d0/pi) ! G cancels out as G=1 in code - coldensi = 0.368d0*coldensi ! n=2 in polytrope formalism Forgan+ 2009 - coldensi = coldensi*umass/udist/udist ! physical units - case (2) - ! Lombardi+ 2015 method of estimating the mean column density - coldensi = 1.014d0 * presi / abs(gradP_cool(i))! 1.014d0 * P/(-gradP/rho) - coldensi = coldensi *umass/udist/udist ! physical units - case (3) - ! Combined method - HStam = sqrt(abs(poti*rhoi)/4.0d0/pi)*0.368d0/rhoi - HLom = 1.014d0*presi/abs(gradP_cool(i))/rhoi - Hcomb = 1.d0/sqrt((1.0d0/HLom)**2.0d0 + (1.0d0/HStam)**2.0d0) - coldensi = Hcomb*rhoi - coldensi = coldensi*umass/udist/udist ! physical units - case (4) - ! Modified Lombardi method - HLom = presi/abs(gradP_cool(i))/rhoi - cs2 = presi/rhoi - if (isink_star > 0 .and. ri2 > 0d0) then - Om2 = xyzmh_ptmass(4,isink_star)/(ri2**(1.5)) !NB we are using spherical radius here - else - Om2 = 0d0 - endif - Hmod2 = cs2 * piontwo / (Om2 + 8d0*rpiontwo*rhoi) - Hcomb = 1.d0/sqrt((1.0d0/HLom)**2.0d0 + (1.0d0/Hmod2)) - coldensi = 1.014d0 * Hcomb *rhoi*umass/udist/udist ! physical units - case default - print *, "no case!" - stop - end select - -! Tfloor is from input parameters and is background heating -! Stellar heating - if (isink_star > 0 .and. Lstar > 0.d0) then - Tmini4 = Tfloor**4d0 + exp(-coldensi*kappaBari)*(Lstar*solarl/(16d0*pi*steboltz*ri2*udist*udist)) - else - Tmini4 = Tfloor**4d0 - endif - - opaci = (coldensi**2d0)*kappaBari + (1.d0/kappaParti) ! physical units - opac_store(i) = opaci - dudti_rad = 4.d0*steboltz*(Tmini4 - Ti**4.d0)/opaci/unit_ergg*utime! code units - - if (doFLD) then - du_tot = dudt_sph(i) + du_FLDi - else - du_tot = dudt_sph(i) - endif - !If radiative cooling is negligible compared to hydrodynamical heating - ! don't use this method to update energy, just use hydro du/dt - if (abs(dudti_rad/du_tot) < dtcool_crit) then - ! print *, "not cooling/heating for r=",sqrt(ri2),".", dudti_rad,& - ! dudt_sph(i) - energ(i) = ui + du_tot*dti - cycle - endif - - Teqi = du_tot * opaci*unit_ergg/utime ! physical units - du_tot = du_tot + dudti_rad - Teqi = Teqi/4.d0/steboltz - Teqi = Teqi + Tmini4 - if (Teqi < Tmini4) then - Teqi = Tmini4**(1.0/4.0) - else - Teqi = Teqi**(1.0/4.0) - endif - teqi_store(i) = Teqi - - if (Teqi > 9e5) then - print *,"i=",i, "dudt_sph(i)=", dudt_sph(i), "duradi=", dudti_rad, "Ti=", Ti, & - "Tmini=", Tmini4**(1.0/4.0),du_tot,Hcomb, "r=",sqrt(ri2), "ui=", ui, & - "dudt_sph * dti=", dudt_sph(i)*dti - elseif (Teqi < epsilon(Teqi)) then - print *, "Teqi=0.0", "Tmini4=", Tmini4, "coldensi=", coldensi, "Tfloor=",Tfloor,& - "Ti=", Ti, "poti=",poti, "rhoi=", rhoi - endif - - rhoi_cgs = rhoi*unit_density - call getintenerg_opdep(Teqi,rhoi_cgs,ueqi) - ueqi = ueqi/unit_ergg - - call getintenerg_opdep(Tmini4**(1.0/4.0),rhoi_cgs,umini) - umini = umini/unit_ergg - - ! calculate thermalization timescale - if ((du_tot) == 0.d0) then - tthermi = 0d0 - else - tthermi = abs((ueqi - ui)/(du_tot)) - endif - - ttherm_store(i) = tthermi - - ! evolve energy - if (tthermi == 0d0) then - energ(i) = ui ! condition if denominator above is zero - elseif ( (dti/tthermi) < TINY(ui) ) then - energ(i) = ui - else - energ(i) = ui*exp(-dti/tthermi) + ueqi*(1.d0-exp(-dti/tthermi)) !code units - endif - - if (isnan(energ(i)) .or. energ(i) < epsilon(ui)) then - ! print *, "kappaBari=",kappaBari, "kappaParti=",kappaParti - print *, "rhoi=",rhoi*unit_density, "Ti=", Ti, "Teqi=", Teqi - print *, "Tmini=",Tmini4**(1.0/4.0), "ri=", ri2**(0.5) - print *, "opaci=",opaci,"coldensi=",coldensi,"dudt_sphi",dudt_sph(i) - print *, "dt=",dti,"tthermi=", tthermi,"umini=", umini - print *, "dudti_rad=", dudti_rad ,"dudt_fld=",du_fldi,"ueqi=",ueqi,"ui=",ui - call warning("In Stamatellos cooling","energ=NaN or 0. ui",val=ui) - stop - endif - - enddo overpart - !$omp end parallel do - - print *, "radcool min/max u():", minval(energ(1:npart)), maxval(energ(1:npart)) - print *, "radcool min/max Teqi():", minval(Teqi_store(1:npart)), maxval(Teqi_store(1:npart)) -end subroutine radcool_update_energ_loop +end subroutine radcool_update_du subroutine write_options_cooling_radapprox(iunit) diff --git a/src/main/dens.F90 b/src/main/dens.F90 index 771e28de4..64134425d 100644 --- a/src/main/dens.F90 +++ b/src/main/dens.F90 @@ -353,7 +353,7 @@ subroutine densityiterate(icall,npart,nactive,xyzh,vxyzu,divcurlv,divcurlB,Bevol call compute_cell(cell,listneigh,nneigh,getdv,getdB,Bevol,xyzh,vxyzu,fxyzu,fext,xyzcache,rad,apr_level) if (icooling==9 .and. doFLD .and. icall==1) then - call calc_lambda_cell(cell,listneigh,nneigh,xyzh,xyzcache,vxyzu,iphase,gradh,lambda_FLD,urad_FLD) + call calc_lambda_cell(cell,listneigh,nneigh,xyzh,vxyzu,iphase,gradh,lambda_FLD,urad_FLD) endif if (do_export) then @@ -389,7 +389,7 @@ subroutine densityiterate(icall,npart,nactive,xyzh,vxyzu,divcurlv,divcurlB,Bevol call compute_cell(cell,listneigh,nneigh,getdv,getdB,Bevol,xyzh,vxyzu,fxyzu,fext,xyzcache,rad,apr_level) if (icooling==9 .and. doFLD) then - call calc_lambda_cell(cell,listneigh,nneigh,xyzh,xyzcache,vxyzu,iphase,gradh,lambda_FLD,urad_FLD) + call calc_lambda_cell(cell,listneigh,nneigh,xyzh,vxyzu,iphase,gradh,lambda_FLD,urad_FLD) endif if (do_export) then @@ -462,7 +462,7 @@ subroutine densityiterate(icall,npart,nactive,xyzh,vxyzu,divcurlv,divcurlB,Bevol call compute_cell(cell,listneigh,nneigh,getdv,getdB,Bevol,xyzh,vxyzu,fxyzu,fext,xyzcache,rad,apr_level) if (icooling==9 .and. doFLD) then - call calc_lambda_cell(cell,listneigh,nneigh,xyzh,xyzcache,vxyzu,iphase,gradh,lambda_FLD,urad_FLD) + call calc_lambda_cell(cell,listneigh,nneigh,xyzh,vxyzu,iphase,gradh,lambda_FLD,urad_FLD) endif remote_export = .false. @@ -523,10 +523,9 @@ subroutine densityiterate(icall,npart,nactive,xyzh,vxyzu,divcurlv,divcurlB,Bevol enddo call reserve_stack(stack_redo,cell%waiting_index) call send_cell(cell,remote_export,irequestsend,xsendbuf,cell_counters,mpitype) ! send the cell to remote - call compute_cell(cell,listneigh,nneigh,getdv,getdB,Bevol,xyzh,vxyzu,fxyzu,fext,xyzcache,rad,apr_level) if (icooling==9 .and. doFLD) then - call calc_lambda_cell(cell,listneigh,nneigh,xyzh,xyzcache,vxyzu,iphase,gradh,lambda_FLD,urad_FLD) + call calc_lambda_cell(cell,listneigh,nneigh,xyzh,vxyzu,iphase,gradh,lambda_FLD,urad_FLD) endif call write_cell(stack_redo,cell) @@ -1293,7 +1292,6 @@ pure subroutine compute_cell(cell,listneigh,nneigh,getdv,getdB,Bevol,xyzh,vxyzu, cell%nneightry = nneigh cell%nneigh(i) = nneighi - enddo over_parts end subroutine compute_cell @@ -1708,7 +1706,7 @@ subroutine store_results(icall,cell,getdv,getdb,realviscosity,stressmax,xyzh,& end subroutine store_results -subroutine calc_lambda_cell(cell,listneigh,nneigh,xyzh,xyzcache,vxyzu,iphase,gradh,lambda,urad_FLD) +subroutine calc_lambda_cell(cell,listneigh,nneigh,xyzh,vxyzu,iphase,gradh,lambda,urad_FLD) use io, only:error use dim, only:maxp use kernel,only:get_kernel,wab0 @@ -1725,7 +1723,6 @@ subroutine calc_lambda_cell(cell,listneigh,nneigh,xyzh,xyzcache,vxyzu,iphase,gra integer, intent(in) :: listneigh(:) integer, intent(in) :: nneigh real, intent(in) :: xyzh(:,:) - real, intent(in) :: xyzcache(:,:) real, intent(in) :: vxyzu(:,:) integer(kind=1), intent(in) :: iphase(:) real(kind=4), intent(in) :: gradh(:,:) diff --git a/src/main/eos.f90 b/src/main/eos.f90 index 8c0af1ce8..93da87aa1 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -635,6 +635,7 @@ subroutine get_TempPresCs(eos_type,xyzi,vxyzui,rhoi,tempi,presi,spsoundi,gammai, endif if (maxvxyzu==4) then + if (vxyzui(4) < 0d0) print *, "ui NEGATIVE in eos" if (use_gamma) then call equationofstate(eos_type,ponrhoi,csi,rhoi,xyzi(1),xyzi(2),xyzi(3),tempi,vxyzui(4),& gamma_local=gammai,mu_local=mu,Xlocal=X,Zlocal=Z) diff --git a/src/main/eos_stamatellos.f90 b/src/main/eos_stamatellos.f90 index 932ef9894..66bf377e9 100644 --- a/src/main/eos_stamatellos.f90 +++ b/src/main/eos_stamatellos.f90 @@ -20,7 +20,7 @@ module eos_stamatellos implicit none real,allocatable,public :: optable(:,:,:) real,allocatable,public :: Gpot_cool(:),duFLD(:),gradP_cool(:),lambda_FLD(:),urad_FLD(:) !gradP_cool=gradP/rho - real,allocatable,public :: ttherm_store(:),teqi_store(:),opac_store(:),duSPH(:) + real,allocatable,public :: ttherm_store(:),ueqi_store(:),opac_store(:),duSPH(:) character(len=25), public :: eos_file= 'eos_lom.dat' !default name of tabulated EOS file logical,public :: doFLD = .True., floor_energy = .False. integer,public :: iunitst=19 @@ -42,14 +42,14 @@ subroutine init_S07cool() call allocate_array('lambda_fld',lambda_fld,npart) call allocate_array('urad_FLD',urad_FLD,npart) call allocate_array('ttherm_store',ttherm_store,npart) - call allocate_array('teqi_store',teqi_store,npart) + call allocate_array('ueqi_store',ueqi_store,npart) call allocate_array('opac_store',opac_store,npart) call allocate_array('duSPH',duSPH,npart) Gpot_cool(:) = 0d0 gradP_cool(:) = 0d0 urad_FLD(:) = 0d0 duFLD(:) = 0d0 - teqi_store(:) = 0d0 + ueqi_store(:) = 0d0 ttherm_store(:) = 0d0 opac_store(:) = 0d0 duSPH(:) = 0d0 @@ -69,7 +69,7 @@ subroutine finish_S07cool() if (allocated(lambda_fld)) deallocate(lambda_fld) if (allocated(urad_FLD)) deallocate(urad_FLD) if (allocated(ttherm_store)) deallocate(ttherm_store) - if (allocated(teqi_store)) deallocate(teqi_store) + if (allocated(ueqi_store)) deallocate(ueqi_store) if (allocated(opac_store)) deallocate(opac_store) if (allocated(duSPH)) deallocate(duSPH) close(iunitst) @@ -128,6 +128,7 @@ subroutine getopac_opdep(ui,rhoi,kappaBar,kappaPart,Ti,gmwi) ! check values are in range of tables if (rhoi > OPTABLE(nx,1,1) .or. rhoi < OPTABLE(1,1,1)) then + print *, "optable rho min =", rhomin call fatal('getopac_opdep','rhoi out of range. Collapsing clump?',var='rhoi',val=rhoi) elseif (ui > OPTABLE(1,ny,3) .or. ui < OPTABLE(1,1,3)) then call fatal('getopac_opdep','ui out of range',var='ui',val=ui) diff --git a/src/main/force.F90 b/src/main/force.F90 index 452f0dd81..976009c63 100644 --- a/src/main/force.F90 +++ b/src/main/force.F90 @@ -3042,25 +3042,28 @@ subroutine finish_cell_and_store_results(icall,cell,fxyzu,xyzh,vxyzu,poten,dt,dv !fxyzu(4,i) = 0. else if (maxvxyzu >= 4) fxyzu(4,i) = fxyz4 - if (icooling == 9) duSPH(i) = fxyz4 + if (icooling == 9) then + call energ_cooling(xi,yi,zi,vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,duhydro=fxyz4,ipart=i) + dusph(i) = fxyz4 + endif endif endif if (mhd) then ! - ! sum returns d(B/rho)/dt, just what we want! + ! sum returns d(b/rho)/dt, just what we want! ! - dBevol(1,i) = fsum(idBevolxi) - dBevol(2,i) = fsum(idBevolyi) - dBevol(3,i) = fsum(idBevolzi) + dbevol(1,i) = fsum(idbevolxi) + dbevol(2,i) = fsum(idbevolyi) + dbevol(3,i) = fsum(idbevolzi) ! - ! hyperbolic/parabolic cleaning terms (dpsi/dt) from Tricco & Price (2012) + ! hyperbolic/parabolic cleaning terms (dpsi/dt) from tricco & price (2012) ! if (psidecayfac > 0.) then vcleani = overcleanfac*vwavei dtau = psidecayfac*vcleani*hi1 ! - ! we clean using the difference operator for div B + ! we clean using the difference operator for div b ! psii = xpartveci(ipsi) diff --git a/src/main/mpi_memory.F90 b/src/main/mpi_memory.f90 similarity index 100% rename from src/main/mpi_memory.F90 rename to src/main/mpi_memory.f90 diff --git a/src/main/readwrite_dumps_fortran.f90 b/src/main/readwrite_dumps_fortran.f90 index 3f8091e34..b29226757 100644 --- a/src/main/readwrite_dumps_fortran.f90 +++ b/src/main/readwrite_dumps_fortran.f90 @@ -71,7 +71,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) use timestep, only:dtmax,idtmax_n,idtmax_frac use part, only:ibin,krome_nmols,T_gas_cool use metric_tools, only:imetric, imet_et - use eos_stamatellos, only:ttherm_store,teqi_store,opac_store + use eos_stamatellos, only:ttherm_store,ueqi_store,opac_store real, intent(in) :: t character(len=*), intent(in) :: dumpfile integer, intent(in), optional :: iorder(:) @@ -250,7 +250,7 @@ subroutine write_fulldump_fortran(t,dumpfile,ntotal,iorder,sphNG) endif ! write stamatellos cooling values if (icooling == 9) then - call write_array(1,teqi_store,'teqi',npart,k,ipass,idump,nums,nerr) + call write_array(1,ueqi_store,'ueqi',npart,k,ipass,idump,nums,nerr) call write_array(1,ttherm_store,'ttherm',npart,k,ipass,idump,nums,nerr) call write_array(1,opac_store,'opacity',npart,k,ipass,idump,nums,nerr) endif diff --git a/src/main/step_leapfrog.F90 b/src/main/step_leapfrog.F90 index 1bfcd95ce..86676275b 100644 --- a/src/main/step_leapfrog.F90 +++ b/src/main/step_leapfrog.F90 @@ -118,6 +118,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) use cons2prim, only:cons2primall use extern_gr, only:get_grforce_all use cooling, only:ufloor,cooling_in_step,Tfloor + use cooling_radapprox,only:radcool_evolve_ui use timing, only:increment_timer,get_timings,itimer_substep use growth, only:check_dustprop use options, only:use_porosity,icooling @@ -158,7 +159,6 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) ibin_dts(ittwas,i) = (int(time_now*ibin_dts(itdt1,i),kind=8) + 0.5)*ibin_dts(itdt,i) enddo endif - !-------------------------------------- ! velocity predictor step, using dtsph !-------------------------------------- @@ -172,14 +172,15 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) !$omp shared(npart,xyzh,vxyzu,fxyzu,iphase,hdtsph,store_itype) & !$omp shared(rad,drad,pxyzu) & !$omp shared(Bevol,dBevol,dustevol,ddustevol,use_dustfrac) & - !$omp shared(dustprop,ddustprop,dustproppred,ufloor,icooling) & + !$omp shared(dustprop,ddustprop,dustproppred,ufloor,icooling,Tfloor) & !$omp shared(mprev,filfacprev,filfac,use_porosity) & !$omp shared(ibin,ibin_old,twas,timei) & !$omp firstprivate(itype) & !$omp private(i,hdti) & !$omp reduction(+:nvfloorp) predictor: do i=1,npart - if (.not.isdead_or_accreted(xyzh(4,i))) then + ! print *, "predictor, i=", i + if (.not.isdead_or_accreted(xyzh(4,i))) then if (ind_timesteps) then if (iactive(iphase(i))) ibin_old(i) = ibin(i) ! only required for ibin_neigh in force.F90 ! @@ -199,13 +200,14 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) else if (icooling == 9) then vxyzu(1:3,i) = vxyzu(1:3,i) + hdti*fxyzu(1:3,i) + call radcool_evolve_ui(vxyzu(4,i),hdti,i,Tfloor,xyzh(4,i)) else vxyzu(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) endif endif !--floor the thermal energy if requested and required - if (ufloor > 0.) then + if (ufloor > 0. .and. icooling /= 9) then if (vxyzu(4,i) < ufloor) then vxyzu(4,i) = ufloor nvfloorp = nvfloorp + 1 @@ -251,7 +253,6 @@ 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 substep(npart,ntypes,nptmass,dtsph,dtextforce,t,xyzh,vxyzu,& fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,& dptmass,linklist_ptmass,fsink_old,nbinmax,ibin_wake,gtgrad, & @@ -280,7 +281,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) !$omp shared(dustevol,ddustprop,dustprop,dustproppred,dustfrac,ddustevol,dustpred,use_dustfrac) & !$omp shared(filfac,filfacpred,use_porosity) & !$omp shared(alphaind,ieos,alphamax,ialphaloc) & -!$omp shared(eos_vars,ufloor,icooling) & +!$omp shared(eos_vars,ufloor,icooling,Tfloor) & !$omp shared(twas,timei) & !$omp shared(rad,drad,radpred)& !$omp private(hi,rhoi,tdecay1,source,ddenom,hdti) & @@ -329,7 +330,12 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (gr) then ppred(:,i) = pxyzu(:,i) + hdti*fxyzu(:,i) else - vpred(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) + if (icooling == 9) then + vpred(1:3,i) = vxyzu(1:3,i) + hdti*fxyzu(1:3,i) + call radcool_evolve_ui(vxyzu(4,i),hdti,i,Tfloor,xyzh(4,i),vpred(4,i)) + else + vpred(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) + endif endif !--floor the thermal energy if requested and required @@ -393,16 +399,13 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (npart > 0) then if (gr) vpred = vxyzu ! Need primitive utherm as a guess in cons2prim - if (icooling == 9) vpred(4,:) = vxyzu(4,:) dt_too_small = .false. call derivs(1,npart,nactive,xyzh,vpred,fxyzu,fext,divcurlv,& divcurlB,Bpred,dBevol,radpred,drad,radprop,dustproppred,ddustprop,& dustpred,ddustevol,filfacpred,dustfrac,eos_vars,timei,dtsph,dtnew,& ppred,dens,metrics,apr_level) - if (do_radiation .and. implicit_radiation) then rad = radpred - vxyzu(4,1:npart) = vpred(4,1:npart) endif if (gr) vxyzu = vpred ! May need primitive variables elsewhere? @@ -492,6 +495,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) else if (icooling == 9) then vxyzu(1:3,i) = vxyzu(1:3,i) + dti*fxyzu(1:3,i) + call radcool_evolve_ui(vxyzu(4,i),dti,i,Tfloor,xyzh(4,i)) else vxyzu(:,i) = vxyzu(:,i) + dti*fxyzu(:,i) endif @@ -518,6 +522,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) else if (icooling == 9) then vxyzu(1:3,i) = vxyzu(1:3,i) + hdti*fxyzu(1:3,i) + call radcool_evolve_ui(vxyzu(4,i),hdti,i,Tfloor,xyzh(4,i)) else vxyzu(:,i) = vxyzu(:,i) + hdti*fxyzu(:,i) endif @@ -525,7 +530,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) !--floor the thermal energy if requested and required if (ufloor > 0.) then - if (vxyzu(4,i) < ufloor) then + if (vxyzu(4,i) < ufloor .and. icooling /= 9) then vxyzu(4,i) = ufloor nvfloorc = nvfloorc + 1 endif @@ -578,7 +583,13 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) vxi = vxyzu(1,i) + hdtsph*fxyzu(1,i) vyi = vxyzu(2,i) + hdtsph*fxyzu(2,i) vzi = vxyzu(3,i) + hdtsph*fxyzu(3,i) - if (maxvxyzu >= 4) eni = vxyzu(4,i) + hdtsph*fxyzu(4,i) + if (maxvxyzu >= 4) then + if (icooling == 9) then + call radcool_evolve_ui(vxyzu(4,i),hdtsph,i,Tfloor,xyzh(4,i),eni) + else + eni = vxyzu(4,i) + hdtsph*fxyzu(4,i) + endif + endif erri = (vxi - vpred(1,i))**2 + (vyi - vpred(2,i))**2 + (vzi - vpred(3,i))**2 errmax = max(errmax,erri) @@ -631,7 +642,7 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) !$omp shared(Bevol,dBevol,Bpred,pxyzu,ppred) & !$omp shared(dustprop,ddustprop,dustproppred,use_dustfrac,dustevol,dustpred,ddustevol) & !$omp shared(filfac,filfacpred,use_porosity) & -!$omp shared(rad,drad,radpred,icooling) & +!$omp shared(rad,drad,radpred,icooling,Tfloor,xyzh) & !$omp firstprivate(itype) & !$omp schedule(static) until_converged: do i=1,npart @@ -668,7 +679,12 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) if (gr) then pxyzu(:,i) = pxyzu(:,i) - hdtsph*fxyzu(:,i) else - vxyzu(:,i) = vxyzu(:,i) - hdtsph*fxyzu(:,i) + if (icooling == 9) then + call radcool_evolve_ui(vxyzu(4,i),-hdtsph,i,Tfloor,xyzh(4,i)) + vxyzu(1:3,i) = vxyzu(1:3,i) - hdtsph*fxyzu(1:3,i) + else + vxyzu(:,i) = vxyzu(:,i) - hdtsph*fxyzu(:,i) + endif endif if (itype==idust .and. use_dustgrowth) dustprop(:,i) = dustprop(:,i) - hdtsph*ddustprop(:,i) if (itype==igas) then @@ -701,9 +717,6 @@ subroutine step(npart,nactive,t,dtsph,dtextforce,dtnew) rad = radpred vxyzu(4,1:npart) = vpred(4,1:npart) endif - if (icooling == 9) then - print *, "after 2nd derivs:vpred", maxval(vpred(4,:)), minval(vpred(4,:)) - endif endif if (icooling == 9 .and. iverbose >=2) then print *, "end of iteration", maxval(vpred(4,:)), minval(vpred(4,:)) diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index 1f68e9ec5..db23978fc 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -335,7 +335,10 @@ subroutine substep_gr(npart,ntypes,dtsph,dtextforce,xyzh,vxyzu,pxyzu,dens,metric elseif (use_apr) then pmassi = aprmassoftype(igas,apr_level(i)) endif - + + if (vxyzu(4,i) < 0d0) then + print *, "u is NEGATIVE in SUBSTEPPING!", vxyzu(4,i),i,dens(i) + endif call equationofstate(ieos,pondensi,spsoundi,dens(i),xyzh(1,i),xyzh(2,i),xyzh(3,i),tempi,vxyzu(4,i)) pri = pondensi*dens(i) call get_grforce(xyzh(:,i),metrics(:,:,:,i),metricderivs(:,:,:,i),vxyzu(1:3,i),dens(i),vxyzu(4,i),pri,fext(1:3,i),dtf) @@ -1205,7 +1208,7 @@ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucl ! ! COOLING ! - if (icooling > 0 .and. cooling_in_step) then + if (icooling > 0 .and. cooling_in_step .and. icooling/=9) then if (h2chemistry) then ! ! Call cooling routine, requiring total density, some distance measure and @@ -1224,8 +1227,8 @@ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucl else call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,dust_temp(i)) endif - elseif (icooling == 9) then - call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,ipart=i) +! elseif (icooling == 9) then +! call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool,ipart=i) else ! cooling without stored dust temperature call energ_cooling(xyzh(1,i),xyzh(2,i),xyzh(3,i),vxyzu(4,i),rhoi,dt,divcurlv(1,i),dudtcool) From b60eef7610eeca6a15ee6b0d8285b5f5f6cab648 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Fri, 8 Nov 2024 11:17:58 +0000 Subject: [PATCH 096/134] Rad approx cooling: prevent bug in substepping --- 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 db23978fc..a0f9a3a75 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -1236,7 +1236,7 @@ subroutine cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucl endif #endif ! update internal energy - if (isionisedi) dudtcool = 0. + if (isionisedi .or. icooling == 9) dudtcool = 0. if (cooling_in_step .or. use_krome) vxyzu(4,i) = vxyzu(4,i) + dt * dudtcool From 1b4c4ac8cfa0484b58306f246f912bbd0d917481 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Tue, 12 Nov 2024 16:39:18 +0000 Subject: [PATCH 097/134] New setup designed for icooling=9. This sets the temperature/sound speed profile from the luminosity of the central star. Will need generalizing. --- src/setup/setup_disc.f90 | 93 ++++++++++++++++++++++++++++++++++------ 1 file changed, 79 insertions(+), 14 deletions(-) diff --git a/src/setup/setup_disc.f90 b/src/setup/setup_disc.f90 index 590f8a2b4..362322b83 100644 --- a/src/setup/setup_disc.f90 +++ b/src/setup/setup_disc.f90 @@ -185,6 +185,7 @@ module setup real :: R_in(maxdiscs),R_out(maxdiscs),R_ref(maxdiscs),R_c(maxdiscs) real :: pindex(maxdiscs),disc_m(maxdiscs),sig_ref(maxdiscs),sig_norm(maxdiscs) + real :: T_bg,L_star(maxdiscs) real :: qindex(maxdiscs),H_R(maxdiscs) real :: posangl(maxdiscs),incl(maxdiscs) real :: annulus_m(maxdiscs),R_inann(maxdiscs),R_outann(maxdiscs) @@ -211,7 +212,7 @@ module setup (/'1','2','3','4','5','6','7','8','9' /) logical :: istratify - integer :: nplanets,discstrat + integer :: nplanets,discstrat,lumdisc real :: mplanet(maxplanets),rplanet(maxplanets) real :: accrplanet(maxplanets),inclplan(maxplanets) real :: J2planet(maxplanets),spin_period(maxplanets),obliquity(maxplanets) @@ -325,7 +326,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, rad(iradxi,1:npart)=0.!call set_radiation_and_gas_temperature_equal(npart,xyzh,vxyzu,massoftype,rad) radprop(ikappa,1:npart) = iradkappa endif - + !--remind user to check for warnings and errors write(*,20) 20 format(/, & @@ -442,6 +443,9 @@ subroutine set_default_options()!id) annulus_m = 0.05 R_inann = 1. R_outann = 150. + lumdisc = 0 + L_star(:) = 1. + T_bg = 5. !--dust disc R_indust = 1. @@ -616,6 +620,7 @@ subroutine equation_of_state(gamma) use eos, only:isink,qfacdisc,qfacdisc2,polyk2,beta_z,z0 use options, only:ieos,icooling use options, only:nfulldump,alphau,ipdv_heating,ishock_heating + use eos_stamatellos, only:init_S07cool real, intent(out) :: gamma real :: H_R_atm, cs @@ -705,11 +710,27 @@ subroutine equation_of_state(gamma) endif else - - !--adiabatic - ieos = 2 - gamma = 5./3. - icooling = 3 + !-- adiabatic + if (lumdisc > 0) then + !--for radapprox cooling + print "(/,a)", ' setting ieos=23 and icooling=9 for radiative cooling approximation' + ieos = 23 + icooling = 9 + gamma = 5./3. ! in case it's needed + call init_S07cool() + if (ndiscs > 1) then + print *, "We can't set up multiple radapprox discs yet :,(" + stop + else + cs = get_cs_from_lum(L_star(1),R_ref(1)) + H_R(1) = cs * R_ref(1)**0.5 / sqrt(m1) ! single central star, G=1 + endif + else + !--adiabatic + ieos = 2 + gamma = 5./3. + icooling = 3 + endif if (use_mcfost) then icooling = 0 @@ -2243,8 +2264,20 @@ subroutine setup_interactive(id) ! to be changed also in the the setpart function. !-------------------------------------------------------------------------- if (.not. use_global_iso) then - call prompt('Enter q_index',qindex(1)) - qindex=qindex(1) + if (maxvxyzu > 3) then + call prompt("Do you want to set the disc temperatures from the stellar"// & + "luminosity? (0=no 1=yes",lumdisc) + endif + if (lumdisc > 0) then + !get luminosity ... + call prompt("Enter the luminosity of star",L_star(i)) + call prompt("Enter the background temperature e.g. 10 (K)", T_bg) + qindex(1) = 0.25 + qindex = 0.25 + else + call prompt('Enter q_index',qindex(1)) + qindex=qindex(1) + endif if (nsinks<5) then if (iuse_disc(1)) then call prompt('Enter H/R of circumbinary at R_ref',H_R(1)) @@ -2697,7 +2730,7 @@ subroutine write_setupfile(filename) endif call write_inopt(isetgas(i),'isetgas'//trim(disclabel),'how to set gas density profile' // & ' (0=total disc mass,1=mass within annulus,2=surface density normalisation,' // & - '3=surface density at reference radius,4=minimum Toomre Q)',iunit) + '3=surface density at reference radius,4=minimum Toomre Q,5=minimum Toomre Q and Lstar)',iunit) call write_inopt(itapergas(i),'itapergas'//trim(disclabel), & 'exponentially taper the outer disc profile',iunit) if (itapergas(i)) call write_inopt(itapersetgas(i),'itapersetgas'//trim(disclabel), & @@ -2735,12 +2768,22 @@ subroutine write_setupfile(filename) call write_inopt(sig_ref(i),'sig_ref'//trim(disclabel),'sigma at reference radius',iunit) case (4) call write_inopt(Q_min(i),'Q_min'//trim(disclabel),'minimum Toomre Q',iunit) + end select + call write_inopt(lumdisc,'lumdisc', 'Set qindex from stellar luminosity (ieos=23) (0=no 1=yes)',iunit) + if (lumdisc > 0) then + call write_inopt(L_star(i),'L_star'//trim(disclabel),'Stellar luminosity (Lsun)',iunit) + call write_inopt(T_bg,'T_bg'//trim(disclabel),'background Temperature (K)',iunit) + endif call write_inopt(pindex(i),'pindex'//trim(disclabel),'power law index of surface density sig=sig0*r^-p',iunit) - call write_inopt(qindex(i),'qindex'//trim(disclabel),'power law index of sound speed cs=cs0*r^-q',iunit) + if (lumdisc == 0) then + call write_inopt(qindex(i),'qindex'//trim(disclabel),'power law index of sound speed cs=cs0*r^-q',iunit) + endif call write_inopt(posangl(i),'posangl'//trim(disclabel),'position angle (deg)',iunit) call write_inopt(incl(i),'incl'//trim(disclabel),'inclination (deg)',iunit) - if (discstrat == 0) call write_inopt(H_R(i),'H_R'//trim(disclabel),'H/R at R=R_ref',iunit) + if (discstrat == 0 .and. lumdisc == 0) then + call write_inopt(H_R(i),'H_R'//trim(disclabel),'H/R at R=R_ref',iunit) + endif if (iwarp(i)) then call write_inopt(R_warp(i),'R_warp'//trim(disclabel),'warp radius',iunit) call write_inopt(H_warp(i),'H_warp'//trim(disclabel),'warp smoothing length',iunit) @@ -3025,6 +3068,8 @@ subroutine read_setupfile(filename,ierr) end select call read_inopt(discstrat,'discstrat',db,errcount=nerr) + call read_inopt(lumdisc,'lumdisc',db,errcount=nerr) + print *, "read lumdisc=", lumdisc if (discstrat==1) then call read_inopt(istrat,'istrat',db,errcount=nerr) call read_inopt(z0_ref,'z0',db,errcount=nerr) @@ -3136,10 +3181,12 @@ subroutine read_setupfile(filename,ierr) call read_inopt(Q_min(i),'Q_min'//trim(disclabel),db,min=0.,errcount=nerr) end select call read_inopt(pindex(i),'pindex'//trim(disclabel),db,errcount=nerr) - call read_inopt(qindex(i),'qindex'//trim(disclabel),db,errcount=nerr) + if (lumdisc == 0) call read_inopt(qindex(i),'qindex'//trim(disclabel),db,errcount=nerr) call read_inopt(posangl(i),'posangl'//trim(disclabel),db,min=0.,max=360.,errcount=nerr) call read_inopt(incl(i),'incl'//trim(disclabel),db,min=0.,max=180.,errcount=nerr) - if (discstrat == 0) call read_inopt(H_R(i),'H_R'//trim(disclabel),db,min=0.,errcount=nerr) + if (discstrat == 0 .and. lumdisc == 0) then + call read_inopt(H_R(i),'H_R'//trim(disclabel),db,min=0.,errcount=nerr) + endif call read_inopt(iwarp(i),'iwarp'//trim(disclabel),db,errcount=nerr) if (iwarp(i)) then call read_inopt(R_warp(i),'R_warp'//trim(disclabel),db,min=0.,errcount=nerr) @@ -3214,6 +3261,13 @@ subroutine read_setupfile(filename,ierr) if (do_radiation) call read_inopt(iradkappa,'radkappa',db,err=ierr) + if (lumdisc > 0) then + call read_inopt(L_star(1),'L_star',db,min=0.,errcount=ierr) + print *, "read L_star", L_star + call read_inopt(T_bg,'T_bg',db,min=0.,errcount=ierr) + print *, "read T_bg", T_bg + endif + call close_db(db) ierr = nerr if (nerr > 0) then @@ -3492,5 +3546,16 @@ subroutine get_hier_disc_label(i, disclabel) end subroutine get_hier_disc_label +real function get_cs_from_lum(L_star,r) + use physcon, only:kb_on_mh,steboltz,solarl,fourpi + use units, only:udist,unit_velocity + real,intent(in) :: L_star,r + real :: mu + + mu = 2.3 !mean molecular mass + get_cs_from_lum = sqrt(kb_on_mh/mu) * ( (L_star*solarl/(fourpi*steboltz))**0.125 / & + (r*udist)**0.25 + sqrt(T_bg) ) + get_cs_from_lum = get_cs_from_lum/unit_velocity +end function end module setup From 1506740b0315ecd29bd596ce6cbf868d30380981 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Tue, 12 Nov 2024 16:40:25 +0000 Subject: [PATCH 098/134] removed duplicated opacity table read --- src/main/cooling.f90 | 4 ---- src/main/eos_stamatellos.f90 | 29 +++++++++++++++-------------- 2 files changed, 15 insertions(+), 18 deletions(-) diff --git a/src/main/cooling.f90 b/src/main/cooling.f90 index 0bb572586..946cf2b70 100644 --- a/src/main/cooling.f90 +++ b/src/main/cooling.f90 @@ -90,10 +90,6 @@ subroutine init_cooling(id,master,iprint,ierr) var='ieos',ival=ieos) if (irealvisc > 0 .and. od_method == 4) call warning('cooling',& 'Using real viscosity will affect optical depth estimate',var='irealvisc',ival=irealvisc) - inquire(file=eos_file,exist=ex) - if (.not. ex ) call fatal('cooling','file not found',var=eos_file) - if (ieos == 2) call read_optab(eos_file,ierr) - if (ierr > 0) call fatal('cooling','Failed to read EOS file',var='ierr',ival=ierr) call init_star() case(6) call init_cooling_KI02(ierr) diff --git a/src/main/eos_stamatellos.f90 b/src/main/eos_stamatellos.f90 index 932ef9894..299cb05a0 100644 --- a/src/main/eos_stamatellos.f90 +++ b/src/main/eos_stamatellos.f90 @@ -32,19 +32,19 @@ module eos_stamatellos contains subroutine init_S07cool() - use part, only:npart,maxradprop + use dim, only:maxp use allocutils, only:allocate_array - print *, "Allocating cooling arrays" - call allocate_array('gradP_cool',gradP_cool,npart) - call allocate_array('Gpot_cool',Gpot_cool,npart) - call allocate_array('duFLD',duFLD,npart) - call allocate_array('lambda_fld',lambda_fld,npart) - call allocate_array('urad_FLD',urad_FLD,npart) - call allocate_array('ttherm_store',ttherm_store,npart) - call allocate_array('teqi_store',teqi_store,npart) - call allocate_array('opac_store',opac_store,npart) - call allocate_array('duSPH',duSPH,npart) + print *, "Allocating cooling arrays for maxp=",maxp + call allocate_array('gradP_cool',gradP_cool,maxp) + call allocate_array('Gpot_cool',Gpot_cool,maxp) + call allocate_array('duFLD',duFLD,maxp) + call allocate_array('lambda_fld',lambda_fld,maxp) + call allocate_array('urad_FLD',urad_FLD,maxp) + call allocate_array('ttherm_store',ttherm_store,maxp) + call allocate_array('teqi_store',teqi_store,maxp) + call allocate_array('opac_store',opac_store,maxp) + call allocate_array('duSPH',duSPH,maxp) Gpot_cool(:) = 0d0 gradP_cool(:) = 0d0 urad_FLD(:) = 0d0 @@ -53,7 +53,7 @@ subroutine init_S07cool() ttherm_store(:) = 0d0 opac_store(:) = 0d0 duSPH(:) = 0d0 - open (unit=iunitst,file='EOSinfo.dat',status='replace') + !open (unit=iunitst,file='EOSinfo.dat',status='replace') if (doFLD) then print *, "Using Forgan+ 2009 hybrid cooling method (FLD)" else @@ -62,7 +62,7 @@ subroutine init_S07cool() end subroutine init_S07cool subroutine finish_S07cool() - deallocate(optable) + if (allocated(optable)) deallocate(optable) if (allocated(gradP_cool)) deallocate(gradP_cool) if (allocated(Gpot_cool)) deallocate(Gpot_cool) if (allocated(duFLD)) deallocate(duFLD) @@ -72,7 +72,7 @@ subroutine finish_S07cool() if (allocated(teqi_store)) deallocate(teqi_store) if (allocated(opac_store)) deallocate(opac_store) if (allocated(duSPH)) deallocate(duSPH) - close(iunitst) +! close(iunitst) end subroutine finish_S07cool subroutine read_optab(eos_file,ierr) @@ -89,6 +89,7 @@ subroutine read_optab(eos_file,ierr) if (ierr > 0) return do read(10,'(A120)') junk + print *, junk if (len(trim(adjustl(junk))) == 0) cycle ! blank line if ((index(adjustl(junk),"::") == 0) .and. (index(adjustl(junk),"#") .ne. 1 )) then !ignore comment lines junk = adjustl(junk) From 9ca68cb10b2b360e389cda75fb1abac75e4542eb Mon Sep 17 00:00:00 2001 From: Alison Young Date: Wed, 13 Nov 2024 09:27:05 +0000 Subject: [PATCH 099/134] Deleted unused module imports --- src/main/cooling.f90 | 1 - 1 file changed, 1 deletion(-) diff --git a/src/main/cooling.f90 b/src/main/cooling.f90 index 946cf2b70..e82b0bb47 100644 --- a/src/main/cooling.f90 +++ b/src/main/cooling.f90 @@ -69,7 +69,6 @@ subroutine init_cooling(id,master,iprint,ierr) use cooling_ism, only:init_cooling_ism,abund_default use cooling_koyamainutsuka, only:init_cooling_KI02 use cooling_solver, only:init_cooling_solver - use eos_stamatellos, only:read_optab,eos_file use cooling_radapprox, only:init_star,od_method use viscosity, only:irealvisc From 27448859f358da0769427c2416eb9a8776e61320 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Wed, 13 Nov 2024 09:29:54 +0000 Subject: [PATCH 100/134] Removed superfluous optab read from cooling.f90 --- src/main/cooling.f90 | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/main/cooling.f90 b/src/main/cooling.f90 index f7953f911..610acb7c2 100644 --- a/src/main/cooling.f90 +++ b/src/main/cooling.f90 @@ -69,7 +69,6 @@ subroutine init_cooling(id,master,iprint,ierr) use cooling_ism, only:init_cooling_ism,abund_default use cooling_koyamainutsuka, only:init_cooling_KI02 use cooling_solver, only:init_cooling_solver - use eos_stamatellos, only:read_optab,eos_file use cooling_radapprox, only:init_star,od_method use viscosity, only:irealvisc @@ -89,8 +88,6 @@ subroutine init_cooling(id,master,iprint,ierr) var='ieos',ival=ieos) if (irealvisc > 0 .and. od_method == 4) call warning('cooling',& 'Using real viscosity will affect optical depth estimate',var='irealvisc',ival=irealvisc) - if (ieos == 2) call read_optab(eos_file,ierr) - if (ierr > 0) call fatal('cooling','Failed to read EOS file',var='ierr',ival=ierr) call init_star() case(6) call init_cooling_KI02(ierr) From a3b6ba56764c9fb201741bc14ec82587df72e2c2 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Fri, 15 Nov 2024 16:59:28 +0000 Subject: [PATCH 101/134] Edits to setup_disc.f90 --- src/main/eos_stamatellos.f90 | 2 +- src/setup/setup_disc.f90 | 11 +++++------ 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/src/main/eos_stamatellos.f90 b/src/main/eos_stamatellos.f90 index 603ad786f..63da59067 100644 --- a/src/main/eos_stamatellos.f90 +++ b/src/main/eos_stamatellos.f90 @@ -42,7 +42,7 @@ subroutine init_S07cool() call allocate_array('lambda_fld',lambda_fld,maxp) call allocate_array('urad_FLD',urad_FLD,maxp) call allocate_array('ttherm_store',ttherm_store,maxp) - call allocate_array('ueqi_store',teqi_store,maxp) + call allocate_array('ueqi_store',ueqi_store,maxp) call allocate_array('opac_store',opac_store,maxp) call allocate_array('duSPH',duSPH,maxp) diff --git a/src/setup/setup_disc.f90 b/src/setup/setup_disc.f90 index 362322b83..11ddfc140 100644 --- a/src/setup/setup_disc.f90 +++ b/src/setup/setup_disc.f90 @@ -621,6 +621,7 @@ subroutine equation_of_state(gamma) use options, only:ieos,icooling use options, only:nfulldump,alphau,ipdv_heating,ishock_heating use eos_stamatellos, only:init_S07cool + use physcon, only:twopi real, intent(out) :: gamma real :: H_R_atm, cs @@ -722,7 +723,7 @@ subroutine equation_of_state(gamma) print *, "We can't set up multiple radapprox discs yet :,(" stop else - cs = get_cs_from_lum(L_star(1),R_ref(1)) + cs = get_cs_from_lum(L_star(1),R_ref(1)) / sqrt(twopi) H_R(1) = cs * R_ref(1)**0.5 / sqrt(m1) ! single central star, G=1 endif else @@ -3069,7 +3070,7 @@ subroutine read_setupfile(filename,ierr) call read_inopt(discstrat,'discstrat',db,errcount=nerr) call read_inopt(lumdisc,'lumdisc',db,errcount=nerr) - print *, "read lumdisc=", lumdisc + if (discstrat==1) then call read_inopt(istrat,'istrat',db,errcount=nerr) call read_inopt(z0_ref,'z0',db,errcount=nerr) @@ -3262,10 +3263,8 @@ subroutine read_setupfile(filename,ierr) if (do_radiation) call read_inopt(iradkappa,'radkappa',db,err=ierr) if (lumdisc > 0) then - call read_inopt(L_star(1),'L_star',db,min=0.,errcount=ierr) - print *, "read L_star", L_star - call read_inopt(T_bg,'T_bg',db,min=0.,errcount=ierr) - print *, "read T_bg", T_bg + call read_inopt(L_star(1),'L_star',db,min=0.,errcount=nerr) + call read_inopt(T_bg,'T_bg',db,min=0.,errcount=nerr) endif call close_db(db) From edd51c9d973ff1e10de252485bded93e2479bb92 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Mon, 18 Nov 2024 16:27:18 +0000 Subject: [PATCH 102/134] Added eos=23 handling to analysis_disc_stresses.f90 --- src/utils/analysis_disc_stresses.f90 | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/src/utils/analysis_disc_stresses.f90 b/src/utils/analysis_disc_stresses.f90 index ea1f79c52..8fe638193 100644 --- a/src/utils/analysis_disc_stresses.f90 +++ b/src/utils/analysis_disc_stresses.f90 @@ -47,6 +47,8 @@ module analysis subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) use io, only:fatal use part, only:gravity,mhd,eos_vars + use eos, only:ieos + use eos_stamatellos, only:eos_file,read_optab character(len=*), intent(in) :: dumpfile real, intent(in) :: xyzh(:,:),vxyzu(:,:) @@ -54,6 +56,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) integer, intent(in) :: npart,iunit,numfile character(len=9) :: output + integer :: ierr ! Code calculates the following alphas: @@ -71,6 +74,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) ! Read analysis options call read_analysis_options + if (ieos==23) call read_optab(eos_file,ierr) if (mhd) print*, 'This is an MHD dump: will calculate Maxwell Stress' @@ -365,7 +369,7 @@ subroutine radial_binning(npart,xyzh,vxyzu,pmass,eos_vars) real,intent(in) :: pmass real,intent(in) :: xyzh(:,:),vxyzu(:,:),eos_vars(:,:) - integer :: ibin,ipart,nbinned,iallocerr + integer :: ibin,ipart,nbinned,iallocerr,ierr real :: area,csi print '(a,I4)', 'Carrying out radial binning, number of bins: ',nbins @@ -465,7 +469,6 @@ subroutine calc_stresses(npart,xyzh,vxyzu,pmass) use units, only: print_units, umass,udist,utime,unit_velocity,unit_density,unit_Bfield use dim, only: gravity use part, only: mhd,rhoh,alphaind,imu,itemp - use eos, only: ieos implicit none @@ -499,9 +502,9 @@ subroutine calc_stresses(npart,xyzh,vxyzu,pmass) call print_units sigma(:) = sigma(:)*umass/(udist*udist) - if (ieos /= 21) then +! if (ieos /= 23) then csbin(:) = csbin(:)*unit_velocity - endif + !endif omega(:) = omega(:)/utime Keplog = 1.5 @@ -659,7 +662,7 @@ end subroutine calculate_H !+ !------------------------------------------------------- subroutine deallocate_arrays - + use eos_stamatellos, only:optable implicit none deallocate(gravxyz) @@ -670,6 +673,7 @@ subroutine deallocate_arrays deallocate(sigma,csbin,H,toomre_q,omega,epicyc) deallocate(alpha_reyn,alpha_grav,alpha_mag,alpha_art) deallocate(part_scaleheight) + if (allocated(optable)) deallocate(optable) end subroutine deallocate_arrays !------------------------------------------------------- From bdffd765f72245b158143272ec7c3e5452f56431 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Mon, 25 Nov 2024 11:21:00 +0000 Subject: [PATCH 103/134] finalised sgdisc setup for radiative approx cooling --- src/setup/setup_disc.f90 | 6 +++--- src/utils/analysis_disc_stresses.f90 | 14 +++++++++----- 2 files changed, 12 insertions(+), 8 deletions(-) diff --git a/src/setup/setup_disc.f90 b/src/setup/setup_disc.f90 index 11ddfc140..403e99694 100644 --- a/src/setup/setup_disc.f90 +++ b/src/setup/setup_disc.f90 @@ -621,7 +621,7 @@ subroutine equation_of_state(gamma) use options, only:ieos,icooling use options, only:nfulldump,alphau,ipdv_heating,ishock_heating use eos_stamatellos, only:init_S07cool - use physcon, only:twopi + use physcon, only:rpiontwo real, intent(out) :: gamma real :: H_R_atm, cs @@ -722,8 +722,8 @@ subroutine equation_of_state(gamma) if (ndiscs > 1) then print *, "We can't set up multiple radapprox discs yet :,(" stop - else - cs = get_cs_from_lum(L_star(1),R_ref(1)) / sqrt(twopi) + else + cs = get_cs_from_lum(L_star(1),R_ref(1)) / rpiontwo H_R(1) = cs * R_ref(1)**0.5 / sqrt(m1) ! single central star, G=1 endif else diff --git a/src/utils/analysis_disc_stresses.f90 b/src/utils/analysis_disc_stresses.f90 index ea1f79c52..8fe638193 100644 --- a/src/utils/analysis_disc_stresses.f90 +++ b/src/utils/analysis_disc_stresses.f90 @@ -47,6 +47,8 @@ module analysis subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) use io, only:fatal use part, only:gravity,mhd,eos_vars + use eos, only:ieos + use eos_stamatellos, only:eos_file,read_optab character(len=*), intent(in) :: dumpfile real, intent(in) :: xyzh(:,:),vxyzu(:,:) @@ -54,6 +56,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) integer, intent(in) :: npart,iunit,numfile character(len=9) :: output + integer :: ierr ! Code calculates the following alphas: @@ -71,6 +74,7 @@ subroutine do_analysis(dumpfile,numfile,xyzh,vxyzu,pmass,npart,time,iunit) ! Read analysis options call read_analysis_options + if (ieos==23) call read_optab(eos_file,ierr) if (mhd) print*, 'This is an MHD dump: will calculate Maxwell Stress' @@ -365,7 +369,7 @@ subroutine radial_binning(npart,xyzh,vxyzu,pmass,eos_vars) real,intent(in) :: pmass real,intent(in) :: xyzh(:,:),vxyzu(:,:),eos_vars(:,:) - integer :: ibin,ipart,nbinned,iallocerr + integer :: ibin,ipart,nbinned,iallocerr,ierr real :: area,csi print '(a,I4)', 'Carrying out radial binning, number of bins: ',nbins @@ -465,7 +469,6 @@ subroutine calc_stresses(npart,xyzh,vxyzu,pmass) use units, only: print_units, umass,udist,utime,unit_velocity,unit_density,unit_Bfield use dim, only: gravity use part, only: mhd,rhoh,alphaind,imu,itemp - use eos, only: ieos implicit none @@ -499,9 +502,9 @@ subroutine calc_stresses(npart,xyzh,vxyzu,pmass) call print_units sigma(:) = sigma(:)*umass/(udist*udist) - if (ieos /= 21) then +! if (ieos /= 23) then csbin(:) = csbin(:)*unit_velocity - endif + !endif omega(:) = omega(:)/utime Keplog = 1.5 @@ -659,7 +662,7 @@ end subroutine calculate_H !+ !------------------------------------------------------- subroutine deallocate_arrays - + use eos_stamatellos, only:optable implicit none deallocate(gravxyz) @@ -670,6 +673,7 @@ subroutine deallocate_arrays deallocate(sigma,csbin,H,toomre_q,omega,epicyc) deallocate(alpha_reyn,alpha_grav,alpha_mag,alpha_art) deallocate(part_scaleheight) + if (allocated(optable)) deallocate(optable) end subroutine deallocate_arrays !------------------------------------------------------- From 1d0ab01fcfcf5463e8a4580c9f8134cc6cc46bbb Mon Sep 17 00:00:00 2001 From: Alison Young Date: Mon, 25 Nov 2024 17:12:47 +0000 Subject: [PATCH 104/134] Tidying cooling_radapprox.f90 --- src/main/cooling_radapprox.f90 | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/src/main/cooling_radapprox.f90 b/src/main/cooling_radapprox.f90 index 373f8ddc3..3b7bc7701 100644 --- a/src/main/cooling_radapprox.f90 +++ b/src/main/cooling_radapprox.f90 @@ -90,17 +90,11 @@ subroutine radcool_evolve_ui(ui,dt,i,Tfloor,h,uout) ! if tthermi ==0 or dt/thermi is neglible then ui doesn't change if (isnan(utemp) .or. utemp < epsilon(utemp)) then -! print *, "oh no i=",i,"ui=",ui,"tthermi=",tthermi,dt,"ueqi",ueqi,rhoi_cgs - ! print *, exp(-dt/tthermi),1.d0-exp(-dt/tthermi) -! call warning("In radcool_evolve_ui","energ=NaN or 0. ui=",val=utemp) utemp = ui endif endif -!else - ! print *, "no_update", tthermi,dt,ui,ueqi - !endif if (utemp < ufloor_cgs/unit_ergg) utemp = ufloor_cgs/unit_ergg - if (utemp < 0d0) print *, "ERRRORRR! i=",i, ui,ueqi + if (utemp < 0d0) print *, "ERROR! i=",i, ui,ueqi if (present(uout)) then uout = utemp From 01b065d0274b03845ea5e7093607607858b9d951 Mon Sep 17 00:00:00 2001 From: Alison Young Date: Tue, 26 Nov 2024 16:01:10 +0000 Subject: [PATCH 105/134] tidying radapprox sgdisc setup --- src/main/cooling_radapprox.f90 | 2 +- src/setup/setup_disc.f90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/main/cooling_radapprox.f90 b/src/main/cooling_radapprox.f90 index 3b7bc7701..ead30bd4e 100644 --- a/src/main/cooling_radapprox.f90 +++ b/src/main/cooling_radapprox.f90 @@ -111,7 +111,7 @@ end subroutine radcool_evolve_ui ! update energy to return evolved energy array. Called from substep subroutine radcool_update_du(i,xi,yi,zi,rhoi,ui,duhydro,Tfloor) use io, only:warning - use physcon, only:steboltz,pi,solarl,Rg,kb_on_mh,piontwo,rpiontwo + use physcon, only:steboltz,pi,solarl,kb_on_mh,piontwo,rpiontwo use units, only:umass,udist,unit_density,unit_ergg,utime,unit_pressure use eos_stamatellos, only:getopac_opdep,getintenerg_opdep,gradP_cool,Gpot_cool,& duFLD,doFLD,ttherm_store,ueqi_store,opac_store diff --git a/src/setup/setup_disc.f90 b/src/setup/setup_disc.f90 index 403e99694..9bd332979 100644 --- a/src/setup/setup_disc.f90 +++ b/src/setup/setup_disc.f90 @@ -3551,7 +3551,7 @@ real function get_cs_from_lum(L_star,r) real,intent(in) :: L_star,r real :: mu - mu = 2.3 !mean molecular mass + mu = 2.381 !mean molecular mass get_cs_from_lum = sqrt(kb_on_mh/mu) * ( (L_star*solarl/(fourpi*steboltz))**0.125 / & (r*udist)**0.25 + sqrt(T_bg) ) get_cs_from_lum = get_cs_from_lum/unit_velocity From 911ad654483474bf718e4cef92b21a83f5a89162 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Thu, 28 Nov 2024 11:39:12 +1100 Subject: [PATCH 106/134] (set_star) allow arbitrary units in the .setup file for radii, masses and orbital properties when setting up stars and binary systems; shift equation of state options for stars inside set_stars options routines --- src/main/units.f90 | 220 +++++++++++++------ src/setup/set_orbit.f90 | 81 +++---- src/setup/set_star.f90 | 394 +++++++++++++++++++++++------------ src/setup/set_star_utils.f90 | 18 +- src/setup/set_units.f90 | 4 +- src/setup/setup_binary.f90 | 41 ++-- src/setup/setup_star.f90 | 204 +++++++++--------- 7 files changed, 597 insertions(+), 365 deletions(-) diff --git a/src/main/units.f90 b/src/main/units.f90 index 8af9b5dc9..9aa59d101 100644 --- a/src/main/units.f90 +++ b/src/main/units.f90 @@ -31,12 +31,16 @@ module units real(kind=8), public :: unit_ergg, unit_energ, unit_opacity, unit_luminosity real(kind=8), public :: unit_angmom - public :: set_units, set_units_extra, print_units + public :: set_units, set_units_extra, print_units, select_unit public :: get_G_code, get_c_code, get_radconst_code, get_kbmh_code - public :: c_is_unity, G_is_unity, in_geometric_units + public :: c_is_unity, G_is_unity, in_geometric_units, in_code_units, in_units public :: is_time_unit, is_length_unit, is_mdot_unit public :: in_solarr, in_solarm, in_solarl + integer, parameter :: len_utype = 10 + + private + contains !------------------------------------------------------------------------------------ @@ -178,12 +182,14 @@ end subroutine print_units ! Subroutine to recognise mass, length and time units from a string !+ !------------------------------------------------------------------------------------ -subroutine select_unit(string,unit,ierr) +subroutine select_unit(string,unit,ierr,unit_type) use physcon - character(len=*), intent(in) :: string - real(kind=8), intent(out) :: unit - integer, intent(out) :: ierr + character(len=*), intent(in) :: string + real(kind=8), intent(out) :: unit + integer, intent(out) :: ierr + character(len=len_utype), intent(out), optional :: unit_type character(len=len(string)) :: unitstr + character(len=len_utype) :: utype real(kind=8) :: fac ierr = 0 @@ -191,53 +197,105 @@ subroutine select_unit(string,unit,ierr) select case(trim(unitstr)) case('solarr','rsun') - unit = solarr + unit = solarr + utype = 'length' + case('jupiterr','rjup','rjupiter') + unit = jupiterr + utype = 'length' case('au') - unit = au + unit = au + utype = 'length' case('ly','lightyear') - unit = ly + unit = ly + utype = 'length' case('pc','parsec') - unit = pc + unit = pc + utype = 'length' case('kpc','kiloparsec') - unit = kpc + unit = kpc + utype = 'length' case('mpc','megaparsec') - unit = mpc + unit = mpc + utype = 'length' case('km','kilometres','kilometers') - unit = km + unit = km + utype = 'length' case('cm','centimetres','centimeters') unit = 1.d0 + utype = 'length' case('solarm','msun') unit = solarm + utype = 'mass' case('earthm','mearth') unit = earthm + utype = 'mass' case('jupiterm','mjup','mjupiter') unit = jupiterm + utype = 'mass' + case('ceresm','mceres') + unit = ceresm + utype = 'mass' case('g','grams') - unit = 1.d0 + unit = gram + utype = 'mass' case('days','day') unit = days + utype = 'time' case('Myr') unit = 1.d6*years + utype = 'time' case('yr','year','yrs','years') unit = years + utype = 'time' case('hr','hour','hrs','hours') unit = hours + utype = 'time' case('min','minute','mins','minutes') unit = minutes + utype = 'time' case('s','sec','second','seconds') unit = seconds - case("g/s","grams/second","g/second","grams/s","g/sec","grams/sec") - unit = 1.d0/seconds - case("Ms/yr","M_s/yr","ms/yr","m_s/yr","Msun/yr","M_sun/yr","Msolar/yr",& - "M_solar/yr","Ms/year","M_s/year","ms/year","m_s/year","Msun/year",& - "M_sun/year","Msolar/year","M_solar/year") + utype = 'time' + case('g/s','grams/second','g/second','grams/s','g/sec','grams/sec') + unit = gram/seconds + utype = 'mdot' + case('Ms/yr','M_s/yr','ms/yr','m_s/yr','Msun/yr','M_sun/yr','Msolar/yr',& + 'M_solar/yr','Ms/year','M_s/year','ms/year','m_s/year','Msun/year',& + 'M_sun/year','Msolar/year','M_solar/year','msun/yr') unit = solarm/years + utype = 'mdot' + case('lsun','solarl','Lsun') + unit = solarl + utype = 'luminosity' + case('erg/s') + unit = 1.d0 + utype = 'luminosity' + case('cm/s') + unit = cm/seconds + utype = 'velocity' + case('m/s') + unit = 1.d2*cm/seconds + utype = 'velocity' + case('km/s') + unit = km/seconds + utype = 'velocity' + case('km/h') + unit = km/hours + utype = 'velocity' + case('au/yr') + unit = au/years + utype = 'velocity' + case('c') + unit = c + utype = 'velocity' case default - ierr = 1 + if (len_trim(unitstr) > 0) ierr = 1 unit = 1.d0 + utype = 'none' end select unit = unit*fac + if (present(unit_type)) unit_type = utype end subroutine select_unit @@ -248,21 +306,14 @@ end subroutine select_unit !------------------------------------------------------------------------------------ logical function is_time_unit(string) character(len=*), intent(in) :: string - character(len=len(string)) :: unitstr - real(kind=8) :: fac + character(len=len_utype) :: unit_type + real :: val integer :: ierr ierr = 0 - call get_unit_multiplier(string,unitstr,fac,ierr) + call select_unit(string,val,ierr,unit_type) - select case(trim(unitstr)) - case('days','day','Myr','yr','year','yrs','years',& - 'hr','hour','hrs','hours','min','minute','mins','minutes',& - 's','sec','second','seconds') - is_time_unit = .true. - case default - is_time_unit = .false. - end select + is_time_unit = (trim(unit_type) == 'time') end function is_time_unit @@ -273,21 +324,14 @@ end function is_time_unit !------------------------------------------------------------------------------------ logical function is_length_unit(string) character(len=*), intent(in) :: string - character(len=len(string)) :: unitstr - real(kind=8) :: fac + character(len=len_utype) :: unit_type + real :: val integer :: ierr ierr = 0 - call get_unit_multiplier(string,unitstr,fac,ierr) + call select_unit(string,val,ierr,unit_type) - select case(trim(unitstr)) - case('solarr','rsun','au','ly','lightyear','pc','parsec',& - 'kpc','kiloparsec','mpc','megaparsec','km','kilometres',& - 'kilometers','cm','centimetres','centimeters') - is_length_unit = .true. - case default - is_length_unit = .false. - end select + is_length_unit = (trim(unit_type) == 'length') end function is_length_unit @@ -298,45 +342,59 @@ end function is_length_unit !------------------------------------------------------------------------------------ logical function is_mdot_unit(string) character(len=*), intent(in) :: string - character(len=len(string)) :: unitstr - real(kind=8) :: fac + character(len=len_utype) :: unit_type + real :: val integer :: ierr ierr = 0 - call get_unit_multiplier(string,unitstr,fac,ierr) + call select_unit(string,val,ierr,unit_type) - select case(trim(unitstr)) - case("g/s","gram/second","g/second","gram/s","g/sec","gram/sec",& - "Ms/yr","M_s/yr","ms/yr","m_s/yr","Msun/yr","M_sun/yr","Msolar/yr",& - "M_solar/yr","Ms/year","M_s/year","ms/year","m_s/year","Msun/year",& - "M_sun/year","Msolar/year","M_solar/year") - is_mdot_unit = .true. - case default - is_mdot_unit = .false. - end select + is_mdot_unit = (trim(unit_type) == 'mdot') end function is_mdot_unit !------------------------------------------------------------------------------------ !+ -! parse a string like "10.*days" or "10*au" and return the value in code units +! parse a string like '10.*days' or '10*au' and return the value in code units ! if there is no recognisable units, the value is returned unscaled !+ !------------------------------------------------------------------------------------ -real function in_code_units(string,ierr) result(rval) +real function in_code_units(string,ierr,unit_type) result(rval) character(len=*), intent(in) :: string integer, intent(out) :: ierr + character(len=*), intent(in), optional :: unit_type real(kind=8) :: val + character(len=len_utype) :: utype + + call select_unit(string,val,ierr,unit_type=utype) + + ! return an error if incorrect dimensions (e.g. mass instead of length) + if (present(unit_type)) then + if ((trim(utype) /= 'none') .and. trim(utype) /= trim(unit_type)) then + ierr = 2 + rval = real(val) + return + endif + endif - call select_unit(string,val,ierr) - if (is_time_unit(string) .and. ierr == 0) then - rval = real(val/utime) - elseif (is_length_unit(string) .and. ierr == 0) then - rval = real(val/udist) - elseif (is_mdot_unit(string) .and. ierr == 0) then - rval = real(val/(umass/utime)) + if (ierr /= 0) then + rval = real(val) + return else - rval = real(val) ! no unit conversion + select case(trim(utype)) + case('time') + rval = real(val/utime) + case('length') + rval = real(val/udist) + case('mass') + rval = real(val/umass) + case('mdot') + rval = real(val/(umass/utime)) + case('luminosity') + rval = real(val/unit_luminosity) + case default + rval = real(val) ! no unit conversion + end select endif end function in_code_units @@ -390,7 +448,7 @@ end subroutine get_unit_multiplier pure logical function is_digit(ch) character(len=1), intent(in) :: ch - is_digit = (iachar(ch) >= iachar('0') .and. iachar(ch) <= iachar('9')) + is_digit = (iachar(ch) >= iachar('0') .and. iachar(ch) <= iachar('9')) .or. (ch=='.') end function is_digit @@ -511,4 +569,36 @@ real(kind=8) function in_solarl(val) result(rval) end function in_solarl +!------------------------------------------------------------------------------------ +!+ +! print a value in physical units, e.g. give code value of mass and +! call this routine print*,in_units(mass,'solarm') +!+ +!------------------------------------------------------------------------------------ +real(kind=8) function in_units(val,unitstring) result(rval) + real, intent(in) :: val + character(len=*), intent(in) :: unitstring + character(len=len_utype) :: utype + integer :: ierr + real :: fac + + call select_unit(unitstring,fac,ierr,unit_type=utype) ! handle errors silently by ignoring ierr + + select case(trim(utype)) + case('time') + rval = fac*val/utime + case('length') + rval = fac*val/udist + case('mass') + rval = fac*val/umass + case('mdot') + rval = fac*val/(umass/utime) + case('luminosity') + rval = fac*val/unit_luminosity + case default + rval = real(fac*val) ! no unit conversion + end select + +end function in_units + end module units diff --git a/src/setup/set_orbit.f90 b/src/setup/set_orbit.f90 index a44a77ff1..605a8a467 100644 --- a/src/setup/set_orbit.f90 +++ b/src/setup/set_orbit.f90 @@ -36,8 +36,10 @@ module setorbit ! define data types with options needed ! to setup an orbit ! + integer, parameter :: len_str = 20 + type campbell_elems - character(len=20) :: semi_major_axis ! string because can specific units + character(len=len_str) :: semi_major_axis ! string because can specific units real :: e ! eccentricity real :: i ! inclination real :: O ! position angle of the ascending node @@ -46,15 +48,15 @@ module setorbit end type campbell_elems type posvel_elems - real :: x1(3) ! position of body 1 - real :: v1(3) ! velocity of body 1 - real :: x2(3) ! position of body 2 - real :: v2(3) ! velocity of body 2 + character(len=len_str) :: x1(3) ! position of body 1 + character(len=len_str) :: v1(3) ! velocity of body 1 + character(len=len_str) :: x2(3) ! position of body 2 + character(len=len_str) :: v2(3) ! velocity of body 2 end type posvel_elems type flyby_elems character(len=20) :: rp ! pericentre distance in arbitrary units - real :: d ! initial separation + character(len=20) :: d ! initial separation in arbitrary units real :: O ! position angle of the ascending node real :: i ! inclination end type flyby_elems @@ -90,18 +92,18 @@ subroutine set_defaults_orbit(orbit) orbit%elems%f = 180. ! start orbit at apocentre orbit%flyby%rp = '10.' - orbit%flyby%d = 100.0 + orbit%flyby%d = '100.0' orbit%flyby%O = 0.0 orbit%flyby%i = 0.0 - orbit%posvel%x1 = 0.0 - orbit%posvel%v1 = 0.0 - orbit%posvel%x2 = 0.0 - orbit%posvel%v2 = 0.0 - orbit%posvel%x1(1) = 10.0 - orbit%posvel%x2(1) = -10.0 - orbit%posvel%v1(2) = 1.0 - orbit%posvel%v2(2) = -1.0 + orbit%posvel%x1 = '0.0' + orbit%posvel%v1 = '0.0' + orbit%posvel%x2 = '0.0' + orbit%posvel%v2 = '0.0' + orbit%posvel%x1(1) = '10.0' + orbit%posvel%x2(1) = '-10.0' + orbit%posvel%v1(2) = '1.0' + orbit%posvel%v2(2) = '-1.0' end subroutine set_defaults_orbit @@ -122,25 +124,33 @@ subroutine set_orbit(orbit,m1,m2,hacc1,hacc2,xyzmh_ptmass,vxyz_ptmass,nptmass,ve logical, intent(in) :: verbose integer, intent(out) :: ierr real, intent(out), optional :: omega_corotate - real :: rp,a + real :: rp,d,a,x1(3),x2(3),v1(3),v2(3) + integer :: i ierr = 0 select case(orbit%itype) case(2) + do i=1,3 + x1(i) = in_code_units(orbit%posvel%x1(i),ierr,unit_type='length') + x2(i) = in_code_units(orbit%posvel%x2(i),ierr,unit_type='length') + v1(i) = in_code_units(orbit%posvel%v1(i),ierr,unit_type='velocity') + v2(i) = in_code_units(orbit%posvel%v2(i),ierr,unit_type='velocity') + enddo ! body 1 - xyzmh_ptmass(1:3,nptmass+1) = orbit%posvel%x1(1:3) + xyzmh_ptmass(1:3,nptmass+1) = x1 xyzmh_ptmass(4,nptmass+1) = m1 xyzmh_ptmass(5,nptmass+1) = hacc1 - vxyz_ptmass(1:3,nptmass+1) = orbit%posvel%v1(1:3) + vxyz_ptmass(1:3,nptmass+1) = v1 ! body 2 - xyzmh_ptmass(1:3,nptmass+2) = orbit%posvel%x2(1:3) + xyzmh_ptmass(1:3,nptmass+2) = x2 xyzmh_ptmass(4,nptmass+2) = m2 xyzmh_ptmass(5,nptmass+2) = hacc2 - vxyz_ptmass(1:3,nptmass+2) = orbit%posvel%v2(1:3) + vxyz_ptmass(1:3,nptmass+2) = v2 case(1) rp = in_code_units(orbit%flyby%rp,ierr) + d = in_code_units(orbit%flyby%d,ierr) - call set_flyby(m1,m2,rp,orbit%flyby%d,hacc1,hacc2,xyzmh_ptmass, & + call set_flyby(m1,m2,rp,d,hacc1,hacc2,xyzmh_ptmass, & vxyz_ptmass,nptmass,ierr,orbit%flyby%O,orbit%flyby%i,verbose=verbose) case default ! @@ -190,21 +200,21 @@ subroutine write_options_orbit(orbit,iunit,label) call write_inopt(orbit%itype,'itype'//trim(c),'type of orbital elements (0=aeiOwf,1=flyby,2=posvel)',iunit) select case(orbit%itype) case(2) - call write_inopt(orbit%posvel%x1(1),'x1'//trim(c),'x position body 1',iunit) - call write_inopt(orbit%posvel%x1(2),'y1'//trim(c),'y position body 1',iunit) - call write_inopt(orbit%posvel%x1(3),'z1'//trim(c),'z position body 1',iunit) - call write_inopt(orbit%posvel%v1(1),'vx1'//trim(c),'x velocity body 1',iunit) - call write_inopt(orbit%posvel%v1(2),'vy1'//trim(c),'y velocity body 1',iunit) - call write_inopt(orbit%posvel%v1(3),'vz1'//trim(c),'z velocity body 1',iunit) - call write_inopt(orbit%posvel%x2(1),'x2'//trim(c),'x position body 2',iunit) - call write_inopt(orbit%posvel%x2(2),'y2'//trim(c),'y position body 2',iunit) - call write_inopt(orbit%posvel%x2(3),'z2'//trim(c),'z position body 2',iunit) - call write_inopt(orbit%posvel%v2(1),'vx2'//trim(c),'x velocity body 2',iunit) - call write_inopt(orbit%posvel%v2(2),'vy2'//trim(c),'y velocity body 2',iunit) - call write_inopt(orbit%posvel%v2(3),'vz2'//trim(c),'z velocity body 2',iunit) + call write_inopt(orbit%posvel%x1(1),'x1'//trim(c),'x position body 1 (code units or e.g. 1*au)',iunit) + call write_inopt(orbit%posvel%x1(2),'y1'//trim(c),'y position body 1 (code units or e.g. 1*au)',iunit) + call write_inopt(orbit%posvel%x1(3),'z1'//trim(c),'z position body 1 (code units or e.g. 1*au)',iunit) + call write_inopt(orbit%posvel%v1(1),'vx1'//trim(c),'x velocity body 1 (code units or e.g. 1*km/s)',iunit) + call write_inopt(orbit%posvel%v1(2),'vy1'//trim(c),'y velocity body 1 (code units or e.g. 1*km/s)',iunit) + call write_inopt(orbit%posvel%v1(3),'vz1'//trim(c),'z velocity body 1 (code units or e.g. 1*km/s)',iunit) + call write_inopt(orbit%posvel%x2(1),'x2'//trim(c),'x position body 2 (code units or e.g. 1*au)',iunit) + call write_inopt(orbit%posvel%x2(2),'y2'//trim(c),'y position body 2 (code units or e.g. 1*au)',iunit) + call write_inopt(orbit%posvel%x2(3),'z2'//trim(c),'z position body 2 (code units or e.g. 1*au)',iunit) + call write_inopt(orbit%posvel%v2(1),'vx2'//trim(c),'x velocity body 2 (code units or e.g. 1*km/s)',iunit) + call write_inopt(orbit%posvel%v2(2),'vy2'//trim(c),'y velocity body 2 (code units or e.g. 1*km/s)',iunit) + call write_inopt(orbit%posvel%v2(3),'vz2'//trim(c),'z velocity body 2 (code units or e.g. 1*km/s)',iunit) case(1) - call write_inopt(orbit%flyby%rp,'rp'//trim(c),'pericentre distance',iunit) - call write_inopt(orbit%flyby%d,'d'//trim(c),'initial separation [same units as rp]',iunit) + call write_inopt(orbit%flyby%rp,'rp'//trim(c),'pericentre distance (code units or e.g. 1*au)',iunit) + call write_inopt(orbit%flyby%d,'d'//trim(c),'initial separation (code units or e.g. 1*au)',iunit) call write_inopt(orbit%flyby%O,'O'//trim(c),'position angle of the ascending node',iunit) call write_inopt(orbit%flyby%i,'i'//trim(c),'inclination',iunit) case default @@ -236,6 +246,7 @@ subroutine read_options_orbit(orbit,db,nerr,label) c = '' if (present(label)) c = trim(adjustl(label)) + call set_defaults_orbit(orbit) call read_inopt(orbit%itype,'itype'//trim(c),db,errcount=nerr,min=0,max=2) select case(orbit%itype) case(2) diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index 94e719333..8997a9cb0 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -8,8 +8,8 @@ module setstar ! ! General routine for setting up a 3D star from a 1D profile ! This is the main functionality from setup_star but in a single routine -! that can also be called from other setups. In principle this -! could also be used to setup multiple stars +! that can also be called from other setups. Also contains +! routines to setup multiple stars ! ! :References: None ! @@ -24,7 +24,7 @@ module setstar ! setstar_utils, unifdis, units, vectorutils ! use setstar_utils, only:ikepler,imesa,ibpwpoly,ipoly,iuniform,ifromfile,ievrard,& - need_polyk + need_polyk,need_mu implicit none ! @@ -37,15 +37,10 @@ module setstar logical :: isinkcore integer :: isofteningopt integer :: np - real :: Rstar - real :: Mstar + character(len=20) :: m,r,rcore,mcore,lcore,hsoft,hacc real :: ui_coef + real :: polyk real :: initialtemp - real :: rcore - real :: mcore - real :: lcore - real :: hsoft - real :: hacc ! accretion radius if star is a sink particle character(len=120) :: input_profile,dens_profile character(len=120) :: outputfilename ! outputfilename is the path to the cored profile character(len=2) :: label ! used to rename relax_star snapshots to relax1, relax2 etc. @@ -64,6 +59,8 @@ module setstar integer, parameter :: istar_offset = 3 ! offset for particle type to distinguish particles ! placed in stars from other particles in the simulation + integer, private :: EOSopt = 1 + private contains @@ -75,22 +72,21 @@ module setstar !+ !-------------------------------------------------------------------------- subroutine set_defaults_star(star) - use units, only:udist,umass - use physcon, only:solarm,solarr type(star_t), intent(out) :: star star%iprofile = 2 - star%rstar = 1.0*real(solarr/udist) - star%mstar = 1.0*real(solarm/umass) + star%r = '1.0' + star%m = '1.0' star%ui_coef = 0.05 + star%polyk = 0. star%initialtemp = 1.0e7 star%isoftcore = 0 star%isinkcore = .false. - star%hsoft = 0. - star%hacc = 1. - star%rcore = 0. - star%mcore = 0. - star%lcore = 0. + star%hsoft = '0.0' + star%hacc = '1.0' + star%rcore = '0.0' + star%mcore = '0.0' + star%lcore = '0.*lsun' star%isofteningopt = 1 ! By default, specify rcore star%np = 1000 star%input_profile = 'P12_Phantom_Profile.data' @@ -115,6 +111,48 @@ subroutine set_defaults_stars(stars) end subroutine set_defaults_stars +!-------------------------------------------------------------------------- +!+ +! utility routine to convert properties to code units while checking +! for errors +!+ +!-------------------------------------------------------------------------- +subroutine check_and_convert(var,desc,unit_type,val,nerr) + use units, only:in_code_units + use io, only:error + character(len=*), intent(in) :: var,desc,unit_type + real, intent(out) :: val + integer, intent(inout) :: nerr + integer :: ierr + + val = in_code_units(var,ierr,unit_type=unit_type) + if (ierr /= 0) then + call error('set_star','error parsing units for '//trim(desc),var=var) + nerr = nerr + 1 + endif + +end subroutine check_and_convert + +!-------------------------------------------------------------------------- +!+ +! utility routine to convert the stellar properties to code units +!+ +!-------------------------------------------------------------------------- +subroutine get_star_properties_in_code_units(star,rstar,mstar,rcore,mcore,hsoft,lcore,hacc,nerr) + type(star_t), intent(in) :: star + real, intent(out) :: rstar,mstar,rcore,mcore,hsoft,lcore,hacc + integer, intent(inout) :: nerr + + call check_and_convert(star%r,'stellar radius','length',rstar,nerr) + call check_and_convert(star%m,'stellar mass','mass',mstar,nerr) + call check_and_convert(star%rcore,'rcore','length',rcore,nerr) + call check_and_convert(star%mcore,'mcore','mass',mcore,nerr) + call check_and_convert(star%hsoft,'core softening','length',hsoft,nerr) + call check_and_convert(star%lcore,'core luminosity','luminosity',lcore,nerr) + call check_and_convert(star%hacc,'accretion radius','length',hacc,nerr) + +end subroutine get_star_properties_in_code_units + !-------------------------------------------------------------------------- !+ ! Master routine to setup a star from a specified file or density profile @@ -122,7 +160,7 @@ end subroutine set_defaults_stars !-------------------------------------------------------------------------- subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& npart,npartoftype,massoftype,hfact,& - xyzmh_ptmass,vxyz_ptmass,nptmass,ieos,polyk,gamma,X_in,Z_in,& + xyzmh_ptmass,vxyz_ptmass,nptmass,ieos,gamma,X_in,Z_in,& relax,use_var_comp,write_rho_to_file,& rhozero,npart_total,mask,ierr,x0,v0,itype,& write_files,density_error,energy_error) @@ -139,7 +177,7 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& use extern_densprofile, only:write_rhotab use unifdis, only:mask_prototype use physcon, only:pi - use units, only:utime,udist,umass,unit_density + use units, only:umass,udist,utime,unit_density use mpiutils, only:reduceall_mpi type(star_t), intent(inout) :: star integer, intent(in) :: id,master @@ -150,7 +188,7 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& real, intent(in) :: hfact logical, intent(in) :: relax,use_var_comp,write_rho_to_file integer, intent(in) :: ieos - real, intent(inout) :: polyk,gamma + real, intent(inout) :: gamma real, intent(in) :: X_in,Z_in real, intent(out) :: rhozero integer(kind=8), intent(out) :: npart_total @@ -160,11 +198,12 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& logical, intent(in), optional :: write_files real, intent(out), optional :: density_error,energy_error procedure(mask_prototype) :: mask - integer :: npts,ierr_relax + integer :: npts,ierr_relax,nerr integer :: ncols_compo,npart_old,i real, allocatable :: r(:),den(:),pres(:),temp(:),en(:),mtab(:),Xfrac(:),Yfrac(:),mu(:) real, allocatable :: composition(:,:) real :: rmin,rhocentre,rmserr,en_err + real :: rstar,mstar,rcore,mcore,hsoft,lcore,hacc character(len=20), allocatable :: comp_label(:) character(len=30) :: lattice ! The lattice type if stretchmap is used logical :: use_exactN,composition_exists,write_dumps @@ -185,14 +224,23 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& return endif ! + ! perform unit conversion on input quantities (if necessary) + ! + nerr = 0 + call get_star_properties_in_code_units(star,rstar,mstar,rcore,mcore,hsoft,lcore,hacc,nerr) + if (nerr /= 0) then + ierr = 2 + return + endif + ! ! get the desired tables of density, pressure, temperature and composition ! as a function of radius / mass fraction ! - call read_star_profile(star%iprofile,ieos,star%input_profile,gamma,polyk,& + call read_star_profile(star%iprofile,ieos,star%input_profile,gamma,star%polyk,& star%ui_coef,r,den,pres,temp,en,mtab,X_in,Z_in,Xfrac,Yfrac,mu,& - npts,rmin,star%rstar,star%mstar,rhocentre,& - star%isoftcore,star%isofteningopt,star%rcore,star%mcore,& - star%hsoft,star%outputfilename,composition,& + npts,rmin,rstar,mstar,rhocentre,& + star%isoftcore,star%isofteningopt,rcore,mcore,& + hsoft,star%outputfilename,composition,& comp_label,ncols_compo) ! @@ -205,26 +253,26 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& ierr = 2 return endif - if (star%mstar < 0.) then + if (mstar < 0.) then call fatal('set_star','cannot set up a star with negative mass!') ierr = 2 return endif - call set_star_density(lattice,id,master,rmin,star%rstar,star%mstar,hfact,& + call set_star_density(lattice,id,master,rmin,rstar,mstar,hfact,& npts,den,r,npart,npartoftype,massoftype,xyzh,use_exactN,& star%np,rhozero,npart_total,mask) ! ! die if stupid things done with GR ! if (gr) then - if (star%rstar < 6.*star%mstar) call fatal('set_star','R < 6GM/c^2 for star in GR violates weak field assumption') + if (rstar < 6.*mstar) call fatal('set_star','R < 6GM/c^2 for star in GR violates weak field assumption') endif ! ! add sink particle stellar core ! if (star%isinkcore) call set_stellar_core(nptmass,xyzmh_ptmass,vxyz_ptmass,ihsoft,& - star%mcore,star%hsoft,ilum,star%lcore,ierr) + mcore,hsoft,ilum,lcore,ierr) if (ierr==1) call fatal('set_stellar_core','mcore <= 0') if (ierr==2) call fatal('set_stellar_core','hsoft <= 0') if (ierr==3) call fatal('set_stellar_core','lcore < 0') @@ -232,7 +280,7 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& ! Write the desired profile to file (do this before relaxation) ! if (write_rho_to_file) call write_rhotab(star%dens_profile,& - r,den,npts,polyk,gamma,rhocentre,ierr) + r,den,npts,star%polyk,gamma,rhocentre,ierr) ! ! mask any existing particles as accreted so they are ! excluded from the centre of mass and relax_star calculations @@ -243,7 +291,7 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& ! if (relax) then if (reduceall_mpi('+',npart)==npart) then - polyk_eos = polyk + polyk_eos = star%polyk call relax_star(npts,den,pres,r,npart,xyzh,use_var_comp,Xfrac,Yfrac,& mu,ierr_relax,npin=npart_old,label=star%label,& write_dumps=write_dumps,density_error=rmserr,energy_error=en_err) @@ -269,7 +317,7 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& ! if (use_var_comp .or. eos_outputs_mu(ieos)) then call set_star_composition(use_var_comp,eos_outputs_mu(ieos),npart,& - xyzh,Xfrac,Yfrac,mu,mtab,star%mstar,eos_vars,npin=npart_old) + xyzh,Xfrac,Yfrac,mu,mtab,mstar,eos_vars,npin=npart_old) endif ! ! Write .comp file containing composition of each particle after interpolation @@ -327,12 +375,12 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& write(*,'(1x,a,f12.5)') 'gamma = ', gamma endif if (maxvxyzu <= 4 .and. need_polyk(star%iprofile)) then - write(*,'(1x,a,f12.5)') 'polyk = ', polyk - write(*,'(1x,a,f12.6,a)') 'specific int. energ = ', polyk*star%rstar/star%mstar,' GM/R' + write(*,'(1x,a,f12.5)') 'polyk = ', star%polyk + write(*,'(1x,a,f12.6,a)') 'specific int. energ = ', star%polyk*rstar/mstar,' GM/R' endif call write_mass('particle mass = ',massoftype(igas),umass) - call write_dist('Radius = ',star%rstar,udist) - call write_mass('Mass = ',star%mstar,umass) + call write_dist('Radius = ',rstar,udist) + call write_mass('Mass = ',mstar,umass) if (star%iprofile==ipoly) then write(*,'(1x,a,g0,a)') 'rho_central = ', rhocentre*unit_density,' g/cm^3' endif @@ -341,9 +389,7 @@ subroutine set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& , rhozero, ' code units' write(*,'(1x,a,es12.5,a)') 'free fall time = ', sqrt(3.*pi/(32.*rhozero))*utime,' s' - if (composition_exists) then - write(*,'(a)') 'Composition written to kepler.comp file.' - endif + if (composition_exists) write(*,'(a)') 'Composition written to .comp file.' write(*,"(70('='))") endif @@ -362,10 +408,13 @@ end subroutine set_star !-------------------------------------------------------------------------- subroutine set_stars(id,master,nstars,star,xyzh,vxyzu,eos_vars,rad,& npart,npartoftype,massoftype,hfact,& - xyzmh_ptmass,vxyz_ptmass,nptmass,ieos,polyk,gamma,X_in,Z_in,& + xyzmh_ptmass,vxyz_ptmass,nptmass,ieos,gamma,X_in,Z_in,& relax,use_var_comp,write_rho_to_file,& rhozero,npart_total,mask,ierr) - use unifdis, only:mask_prototype + use unifdis, only:mask_prototype + use eos, only:init_eos,finish_eos + use eos_piecewise, only:init_eos_piecewise_preset + use io, only:error type(star_t), intent(inout) :: star(:) integer, intent(in) :: id,master,nstars integer, intent(inout) :: npart,npartoftype(:),nptmass @@ -375,7 +424,7 @@ subroutine set_stars(id,master,nstars,star,xyzh,vxyzu,eos_vars,rad,& real, intent(in) :: hfact logical, intent(in) :: relax,use_var_comp,write_rho_to_file integer, intent(in) :: ieos - real, intent(inout) :: polyk,gamma + real, intent(inout) :: gamma real, intent(in) :: X_in,Z_in real, intent(out) :: rhozero integer(kind=8), intent(out) :: npart_total @@ -383,16 +432,26 @@ subroutine set_stars(id,master,nstars,star,xyzh,vxyzu,eos_vars,rad,& procedure(mask_prototype) :: mask integer :: i + print*,' HERE ieos=',ieos,EOSopt + if (ieos==9) call init_eos_piecewise_preset(EOSopt) + call init_eos(ieos,ierr) + if (ierr /= 0) then + call error('setup','could not initialise equation of state') + return + endif + do i=1,min(nstars,size(star)) if (star(i)%iprofile > 0) then print "(/,a,i0,a)",' --- STAR ',i,' ---' call set_star(id,master,star(i),xyzh,vxyzu,eos_vars,rad,npart,npartoftype,& - massoftype,hfact,xyzmh_ptmass,vxyz_ptmass,nptmass,ieos,polyk,gamma,& + massoftype,hfact,xyzmh_ptmass,vxyz_ptmass,nptmass,ieos,gamma,& X_in,Z_in,relax,use_var_comp,write_rho_to_file,& rhozero,npart_total,mask,ierr,itype=i) endif enddo + call finish_eos(ieos,ierr) + end subroutine set_stars !----------------------------------------------------------------------- @@ -525,7 +584,8 @@ subroutine set_defaults_given_profile(iprofile,filename,need_iso,ieos,mstar,poly character(len=120), intent(out) :: filename integer, intent(out) :: need_iso integer, intent(inout) :: ieos - real, intent(inout) :: mstar,polyk + real, intent(inout) :: polyk + character(len=20), intent(out) :: mstar need_iso = 0 select case(iprofile) @@ -546,8 +606,7 @@ subroutine set_defaults_given_profile(iprofile,filename,need_iso,ieos,mstar,poly ! Original Author: Madeline Marshall & Bernard Field ! Supervisors: James Wurster & Paul Lasky ieos = 9 - !dist_unit = 'km' - Mstar = 1.35 + Mstar = '1.35' polyk = 144. case(ievrard) need_iso = -1 @@ -560,28 +619,19 @@ end subroutine set_defaults_given_profile ! interactive prompting for setting up a star !+ !----------------------------------------------------------------------- -subroutine set_star_interactive(id,master,star,need_iso,use_var_comp,ieos,polyk) +subroutine set_star_interactive(id,master,star,need_iso,use_var_comp,ieos) use prompting, only:prompt use setstar_utils, only:nprofile_opts,profile_opt,need_inputprofile,need_rstar - use units, only:in_solarm,in_solarr,in_solarl,udist,umass,unit_luminosity - use physcon, only:solarr,solarm,solarl + use units, only:in_code_units type(star_t), intent(out) :: star integer, intent(in) :: id,master logical, intent(out) :: use_var_comp integer, intent(out) :: need_iso integer, intent(inout) :: ieos - real, intent(inout) :: polyk integer :: i - real :: mstar_msun,rstar_rsun,rcore_rsun,mcore_msun,lcore_lsun,hsoft_rsun ! set defaults call set_defaults_star(star) - mstar_msun = real(in_solarm(star%mstar)) - rstar_rsun = real(in_solarr(star%rstar)) - mcore_msun = real(in_solarm(star%mcore)) - lcore_lsun = real(in_solarl(star%lcore)) - rcore_rsun = real(in_solarr(star%rcore)) - hsoft_rsun = real(in_solarr(star%hsoft)) ! Select sphere & set default values do i = 1, nprofile_opts @@ -594,7 +644,7 @@ subroutine set_star_interactive(id,master,star,need_iso,use_var_comp,ieos,polyk) ! if (id==master) write(*,"('Setting up ',a)") trim(profile_opt(star%iprofile)) call set_defaults_given_profile(star%iprofile,star%input_profile,& - need_iso,ieos,star%mstar,polyk) + need_iso,ieos,star%m,star%polyk) ! resolution if (star%iprofile > 0) then @@ -606,11 +656,9 @@ subroutine set_star_interactive(id,master,star,need_iso,use_var_comp,ieos,polyk) if (need_inputprofile(star%iprofile)) then call prompt('Enter file name containing input profile',star%input_profile) else - call prompt('Enter the mass of the star (Msun)',mstar_msun,0.) - star%mstar = mstar_msun*real(solarm/umass) + call prompt('Enter the mass of the star (e.g. 1*msun)',star%m) if (need_rstar(star%iprofile)) then - call prompt('Enter the radius of the star (Rsun)',rstar_rsun,0.) - star%rstar = rstar_rsun*real(solarr/udist) + call prompt('Enter the radius of the star (e.g. 1*rsun)',star%r) endif endif @@ -628,12 +676,9 @@ subroutine set_star_interactive(id,master,star,need_iso,use_var_comp,ieos,polyk) case(0) call prompt('Add a sink particle stellar core?',star%isinkcore) if (star%isinkcore) then - call prompt('Enter mass of the created sink particle core [Msun]',mcore_msun,0.) - call prompt('Enter softening length of the sink particle core [Rsun]',hsoft_rsun,0.) - call prompt('Enter sink particle luminosity [Lsun]',lcore_lsun,0.) - star%mcore = mcore_msun*real(solarm/umass) - star%hsoft = hsoft_rsun*real(solarr/udist) - star%lcore = lcore_lsun*real(solarl/unit_luminosity) + call prompt('Enter mass of the created sink particle core (e.g. 0.1*Msun)',star%mcore) + call prompt('Enter softening length of the sink particle core (e.g. 0.1*Rsun)',star%hsoft) + call prompt('Enter sink particle luminosity (e.g. 1*Lsun)',star%lcore) endif case(1) star%isinkcore = .true. ! Create sink particle core automatically @@ -647,35 +692,27 @@ subroutine set_star_interactive(id,master,star,need_iso,use_var_comp,ieos,polyk) select case(star%isofteningopt) case(1) - call prompt('Enter core radius [Rsun]',rcore_rsun,0.) - star%rcore = rcore_rsun*real(solarr/udist) + call prompt('Enter core radius (e.g. 0.1*rsun)',star%rcore) case(2) - call prompt('Enter mass of the created sink particle core [Msun]',mcore_msun,0.) - star%mcore = mcore_msun*real(solarm/umass) + call prompt('Enter mass of the created sink particle core (e.g. 0.1*msun)',star%mcore) case(3) - call prompt('Enter mass of the created sink particle core [Msun]',mcore_msun,0.) - call prompt('Enter core radius [Rsun]',rcore_rsun,0.) - star%mcore = mcore_msun*real(solarm/umass) - star%rcore = rcore_rsun*real(solarr/udist) + call prompt('Enter mass of the created sink particle core (e.g. 0.1*msun)',star%mcore) + call prompt('Enter core radius (e.g. 1*rsun)',star%rcore) end select - call prompt('Enter sink particle luminosity [Lsun]',lcore_lsun,0.) - star%lcore = lcore_lsun*real(solarl/unit_luminosity) + call prompt('Enter sink particle luminosity [e.g. 1*Lsun]',star%lcore) case(2) star%isinkcore = .true. ! Create sink particle core automatically print*,'Specify core radius and initial guess for mass of sink particle core' - call prompt('Enter core radius in Rsun : ',rcore_rsun,0.) - call prompt('Enter guess for core mass in Msun : ',mcore_msun,0.) - call prompt('Enter sink particle luminosity [Lsun]',lcore_lsun,0.) + call prompt('Enter core radius (e.g. 0.1*rsun): ',star%rcore) + call prompt('Enter guess for core mass (e.g. 0.1*Msun): ',star%mcore) + call prompt('Enter sink particle luminosity (e.g. 1.*lsun',star%lcore) call prompt('Enter output file name of cored stellar profile:',star%outputfilename) - star%mcore = mcore_msun*real(solarm/umass) - star%rcore = rcore_rsun*real(solarr/udist) - star%lcore = lcore_lsun*real(solarl/unit_luminosity) end select case(ievrard) call prompt('Enter the specific internal energy (units of GM/R) ',star%ui_coef,0.) case(:0) - call prompt('Enter the accretion radius in code units',star%hacc,0.) + call prompt('Enter the accretion radius (e.g. 1.0)',star%hacc) end select end subroutine set_star_interactive @@ -685,12 +722,11 @@ end subroutine set_star_interactive ! write setupfile options needed for a star !+ !----------------------------------------------------------------------- -subroutine write_options_star(star,iunit,label) +subroutine write_options_star(star,iunit,ieos,label) use infile_utils, only:write_inopt,get_optstring - use setstar_utils, only:nprofile_opts,profile_opt,need_inputprofile,need_rstar - use units, only:in_solarm,in_solarr,in_solarl + use setstar_utils, only:nprofile_opts,profile_opt,need_inputprofile,need_rstar,need_polyk type(star_t), intent(in) :: star - integer, intent(in) :: iunit + integer, intent(in) :: iunit,ieos character(len=*), intent(in), optional :: label character(len=120) :: string character(len=10) :: c @@ -708,9 +744,9 @@ subroutine write_options_star(star,iunit,label) call write_inopt(star%input_profile,'input_profile'//trim(c),& 'Path to input profile',iunit) else - call write_inopt(in_solarm(star%Mstar),'Mstar'//trim(c),'mass of star '//trim(c)//' [Msun]',iunit) + call write_inopt(star%m,'Mstar'//trim(c),'mass of star '//trim(c)//' (code units or e.g. 1*msun)',iunit) if (need_rstar(star%iprofile)) & - call write_inopt(in_solarr(star%Rstar),'Rstar'//trim(c),'radius of star'//trim(c)//' [Rsun]',iunit) + call write_inopt(star%r,'Rstar'//trim(c),'radius of star'//trim(c)//' (code units or e.g. 1*rsun)',iunit) endif endif @@ -729,31 +765,28 @@ subroutine write_options_star(star,iunit,label) call write_inopt(star%isofteningopt,'isofteningopt'//trim(c),& '1=supply rcore, 2=supply mcore, 3=supply both',iunit) if ((star%isofteningopt == 1) .or. (star%isofteningopt == 3)) then - call write_inopt(in_solarr(star%rcore),'rcore'//trim(c),'Radius of core softening [Rsun]',iunit) + call write_inopt(star%rcore,'rcore'//trim(c),'Radius of core softening',iunit) endif if ((star%isofteningopt == 2) .or. (star%isofteningopt == 3)) then - call write_inopt(in_solarm(star%mcore),'mcore'//trim(c),& - 'Mass of point mass stellar core [Msun]',iunit) + call write_inopt(star%mcore,'mcore'//trim(c),'Mass of point mass stellar core',iunit) endif elseif (star%isoftcore == 2) then - call write_inopt(in_solarr(star%rcore),'rcore'//trim(c),& - 'Radius of core softening [Rsun]',iunit) - call write_inopt(in_solarm(star%mcore),'mcore'//trim(c),& - 'Initial guess for mass of sink particle stellar core [Msun]',iunit) + call write_inopt(star%rcore,'rcore'//trim(c),'Radius of core softening',iunit) + call write_inopt(star%mcore,'mcore'//trim(c),& + 'Initial guess for mass of sink particle stellar core',iunit) endif - call write_inopt(in_solarl(star%lcore),'lcore'//trim(c),& - 'Luminosity of point mass stellar core [Lsun]',iunit) + call write_inopt(star%lcore,'lcore'//trim(c),& + 'Luminosity of point mass stellar core',iunit) else call write_inopt(star%isinkcore,'isinkcore'//trim(c),& 'Add a sink particle stellar core',iunit) if (star%isinkcore) then - call write_inopt(in_solarm(star%mcore),'mcore'//trim(c),& + call write_inopt(star%mcore,'mcore'//trim(c),& 'Mass of sink particle stellar core',iunit) - call write_inopt(in_solarr(star%hsoft),'hsoft'//trim(c),& - 'Softening length of sink particle stellar core [Rsun]',iunit) + call write_inopt(star%hsoft,'hsoft'//trim(c),& + 'Softening length of sink particle stellar core',iunit) endif - call write_inopt(in_solarl(star%lcore),'lcore'//trim(c),& - 'Luminosity of sink core particle [Lsun]',iunit) + call write_inopt(star%lcore,'lcore'//trim(c),'Luminosity of sink core particle',iunit) endif case (ievrard) call write_inopt(star%ui_coef,'ui_coef'//trim(c),& @@ -762,9 +795,16 @@ subroutine write_options_star(star,iunit,label) call write_inopt(star%hacc,'hacc'//trim(c),'accretion radius for sink'//trim(c),iunit) end select + if (need_polyk(star%iprofile)) call write_inopt(star%polyk,'polyk'//trim(c),'polytropic constant (cs^2 if isothermal)',iunit) + + ! options for setting initial thermal energy (e.g. if degenerate matter eos) + select case(ieos) + case(15) + call write_inopt(star%initialtemp,'initialtemp'//trim(c),'initial temperature of star (e.g. if degenerate matter eos)',iunit) + end select + if (star%iprofile > 0 .and. (len_trim(c)==0 .or. c(1:1)=='1')) then call write_inopt(star%np,'np'//trim(c),'number of particles',iunit) - !call write_inopt(use_exactN,'use_exactN','find closest particle number to np',iunit) endif end subroutine write_options_star @@ -774,21 +814,18 @@ end subroutine write_options_star ! read setupfile options needed for a star !+ !----------------------------------------------------------------------- -subroutine read_options_star(star,need_iso,ieos,polyk,db,nerr,label) +subroutine read_options_star(star,need_iso,ieos,db,nerr,label) use infile_utils, only:inopts,read_inopt use setstar_utils, only:need_inputprofile,need_rstar,nprofile_opts - use units, only:umass,udist,unit_luminosity - use physcon, only:solarm,solarr,solarl type(star_t), intent(out) :: star type(inopts), allocatable, intent(inout) :: db(:) integer, intent(out) :: need_iso integer, intent(inout) :: ieos - real, intent(inout) :: polyk integer, intent(inout) :: nerr character(len=*), intent(in), optional :: label character(len=10) :: c - real :: mcore_msun,rcore_rsun,lcore_lsun,mstar_msun,rstar_rsun,hsoft_rsun integer :: ierr + real :: rstar,mstar,rcore,mcore,hsoft,lcore,hacc ! set defaults call set_defaults_star(star) @@ -800,7 +837,7 @@ subroutine read_options_star(star,need_iso,ieos,polyk,db,nerr,label) call read_inopt(star%iprofile,'iprofile'//trim(c),db,errcount=nerr,min=0,max=nprofile_opts) call set_defaults_given_profile(star%iprofile,star%input_profile,& - need_iso,ieos,star%mstar,polyk) + need_iso,ieos,star%m,star%polyk) if (need_inputprofile(star%iprofile)) then call read_inopt(star%input_profile,'input_profile'//trim(c),db,errcount=nerr) @@ -819,10 +856,8 @@ subroutine read_options_star(star,need_iso,ieos,polyk,db,nerr,label) if (star%isoftcore <= 0) then ! sink particle core without softening call read_inopt(star%isinkcore,'isinkcore'//trim(c),db,errcount=nerr) if (star%isinkcore) then - call read_inopt(mcore_msun,'mcore'//trim(c),db,errcount=nerr,min=0.,err=ierr) - if (ierr==0) star%mcore = mcore_msun*real(solarm/umass) - call read_inopt(hsoft_rsun,'hsoft'//trim(c),db,errcount=nerr,min=0.,err=ierr) - if (ierr==0) star%hsoft = hsoft_rsun*real(solarr/udist) + call read_inopt(star%mcore,'mcore'//trim(c),db,errcount=nerr,err=ierr) + call read_inopt(star%hsoft,'hsoft'//trim(c),db,errcount=nerr,err=ierr) endif else star%isinkcore = .true. @@ -834,24 +869,29 @@ subroutine read_options_star(star,need_iso,ieos,polyk,db,nerr,label) endif if ((star%isofteningopt==1) .or. (star%isofteningopt==3)) then - call read_inopt(rcore_rsun,'rcore'//trim(c),db,errcount=nerr,min=0.,err=ierr) - if (ierr==0) star%rcore = rcore_rsun*real(solarr/udist) + call read_inopt(star%rcore,'rcore'//trim(c),db,errcount=nerr,err=ierr) endif if ((star%isofteningopt==2) .or. (star%isofteningopt==3) & .or. (star%isoftcore==2)) then - call read_inopt(mcore_msun,'mcore'//trim(c),db,errcount=nerr,min=0.,err=ierr) - if (ierr==0) star%mcore = mcore_msun*real(solarm/umass) + call read_inopt(star%mcore,'mcore'//trim(c),db,errcount=nerr,err=ierr) endif endif if (star%isinkcore) then - call read_inopt(lcore_lsun,'lcore'//trim(c),db,errcount=nerr,min=0.,err=ierr) - if (ierr==0) star%lcore = lcore_lsun*real(solarl/unit_luminosity) + call read_inopt(star%lcore,'lcore'//trim(c),db,errcount=nerr,err=ierr) endif case(ievrard) - call read_inopt(star%ui_coef,'ui_coef'//trim(c),db,errcount=nerr,min=0.) + call read_inopt(star%ui_coef,'ui_coef'//trim(c),db,errcount=nerr) case(:0) - call read_inopt(star%hacc,'hacc'//trim(c),db,errcount=nerr,min=0.) + call read_inopt(star%hacc,'hacc'//trim(c),db,errcount=nerr) + end select + + if (need_polyk(star%iprofile)) call read_inopt(star%polyk,'polyk'//trim(c),db,errcount=nerr) + + ! options for setting initial thermal energy (e.g. if degenerate matter eos) + select case(ieos) + case(15) + call read_inopt(star%initialtemp,'initialtemp'//trim(c),db,errcount=nerr,min=0.,max=1e12) end select ! star properties @@ -859,15 +899,16 @@ subroutine read_options_star(star,need_iso,ieos,polyk,db,nerr,label) if (need_inputprofile(star%iprofile)) then call read_inopt(star%input_profile,'input_profile'//trim(c),db,errcount=nerr) else - call read_inopt(mstar_msun,'Mstar'//trim(c),db,errcount=nerr,min=0.,err=ierr) - if (ierr==0) star%mstar = mstar_msun*real(solarm/umass) + call read_inopt(star%m,'Mstar'//trim(c),db,errcount=nerr,err=ierr) if (need_rstar(star%iprofile)) then - call read_inopt(rstar_rsun,'Rstar'//trim(c),db,errcount=nerr,min=0.,err=ierr) - if (ierr==0) star%rstar = rstar_rsun*real(solarr/udist) + call read_inopt(star%r,'Rstar'//trim(c),db,errcount=nerr,err=ierr) endif endif endif + ! perform a unit conversion, just to check that there are no errors parsing the .setup file + call get_star_properties_in_code_units(star,rstar,mstar,rcore,mcore,hsoft,lcore,hacc,nerr) + end subroutine read_options_star !----------------------------------------------------------------------- @@ -875,11 +916,11 @@ end subroutine read_options_star ! write_options routine that writes options for multiple stars !+ !----------------------------------------------------------------------- -subroutine write_options_stars(star,relax,iunit,nstar) +subroutine write_options_stars(star,relax,ieos,iunit,nstar) use relaxstar, only:write_options_relax use infile_utils, only:write_inopt type(star_t), intent(in) :: star(:) - integer, intent(in) :: iunit + integer, intent(in) :: ieos,iunit logical, intent(in) :: relax integer, intent(in), optional :: nstar integer :: i,nstars @@ -894,9 +935,15 @@ subroutine write_options_stars(star,relax,iunit,nstar) ! write options for each star do i=1,nstars - call write_options_star(star(i),iunit,label=achar(i+48)) + call write_options_star(star(i),iunit,ieos,label=achar(i+48)) enddo + ! write equation of state options if any stars made of gas + if (nstars > 0) then + if (any(star(1:nstars)%iprofile > 0)) & + call write_options_stars_eos(star(1:nstars),ieos,iunit) + endif + ! write relaxation options if any stars are made of gas if (nstars > 0) then if (any(star(1:nstars)%iprofile > 0)) then @@ -913,14 +960,13 @@ end subroutine write_options_stars ! read_options routine that reads options for multiple stars !+ !----------------------------------------------------------------------- -subroutine read_options_stars(star,need_iso,ieos,polyk,relax,db,nerr,nstar) +subroutine read_options_stars(star,need_iso,ieos,relax,db,nerr,nstar) use relaxstar, only:read_options_relax use infile_utils, only:inopts,read_inopt type(star_t), intent(out) :: star(:) type(inopts), allocatable, intent(inout) :: db(:) integer, intent(out) :: need_iso integer, intent(inout) :: ieos - real, intent(inout) :: polyk logical, intent(out) :: relax integer, intent(inout) :: nerr integer, intent(out), optional :: nstar @@ -928,15 +974,20 @@ subroutine read_options_stars(star,need_iso,ieos,polyk,relax,db,nerr,nstar) ! optionally ask for number of stars if (present(nstar)) then - call read_inopt(nstar,'nstars',db,nerr,min=0,max=size(star)) + call read_inopt(nstar,'nstars',db,errcount=nerr,min=0,max=size(star)) nstars = nstar else nstars = size(star) endif + ! write equation of state options if any stars made of gas + if (nstars > 0) then + if (any(star(1:nstars)%iprofile > 0)) call read_options_stars_eos(star,ieos,db,nerr) + endif + ! read options for each star do i=1,nstars - call read_options_star(star(i),need_iso,ieos,polyk,db,nerr,label=achar(i+48)) + call read_options_star(star(i),need_iso,ieos,db,nerr,label=achar(i+48)) enddo ! read relaxation options if any stars are made of gas @@ -949,4 +1000,73 @@ subroutine read_options_stars(star,need_iso,ieos,polyk,relax,db,nerr,nstar) end subroutine read_options_stars +!----------------------------------------------------------------------- +!+ +! write equation of state options needed to setup stars +!+ +!----------------------------------------------------------------------- +subroutine write_options_stars_eos(star,ieos,iunit) + use eos, only:use_var_comp,X_in,Z_in,irecomb,gmw,gamma + use infile_utils, only:write_inopt + integer, intent(in) :: ieos,iunit + type(star_t), intent(in) :: star(:) + + write(iunit,"(/,a)") '# equation of state used to set the thermal energy profile' + call write_inopt(ieos,'ieos','1=isothermal,2=adiabatic,10=MESA,12=idealplusrad',iunit) + + if (any(star(:)%iprofile==imesa)) then + call write_inopt(use_var_comp,'use_var_comp','Use variable composition (X, Z, mu)',iunit) + endif + + select case(ieos) + case(9) + write(iunit,"(/,a)") '# Piecewise Polytrope default options' + call write_inopt(EOSopt,'EOSopt','EOS: 1=APR3,2=SLy,3=MS1,4=ENG (from Read et al 2009)',iunit) + case(2,12) + call write_inopt(gamma,'gamma','Adiabatic index',iunit) + if (any(need_mu(star(:)%isoftcore)) .and. (.not. use_var_comp)) call write_inopt(gmw,'mu','mean molecular weight',iunit) + case(10,20) + if (ieos==20) call write_inopt(irecomb,'irecomb','Species to include in recombination (0: H2+H+He, 1:H+He, 2:He',iunit) + if ( (.not. use_var_comp) .and. any(need_mu(star(:)%isoftcore))) then + call write_inopt(X_in,'X','hydrogen mass fraction',iunit) + call write_inopt(Z_in,'Z','metallicity',iunit) + endif + end select + +end subroutine write_options_stars_eos + +!----------------------------------------------------------------------- +!+ +! read equation of state options needed to setup stars +!+ +!----------------------------------------------------------------------- +subroutine read_options_stars_eos(star,ieos,db,nerr) + use eos, only:use_var_comp,X_in,Z_in,irecomb,gamma,gmw + use infile_utils, only:inopts,read_inopt + type(star_t), intent(out) :: star(:) + type(inopts), allocatable, intent(inout) :: db(:) + integer, intent(inout) :: ieos + integer, intent(inout) :: nerr + + ! equation of state + call read_inopt(ieos,'ieos',db,errcount=nerr) + if (any(star(:)%iprofile==imesa)) call read_inopt(use_var_comp,'use_var_comp',db,errcount=nerr) + + select case(ieos) + case(9) + call read_inopt(EOSopt,'EOSopt',db,min=0,max=4,errcount=nerr) + case(2,12) + call read_inopt(gamma,'gamma',db,min=1.,max=7.,errcount=nerr) + if ( (.not. use_var_comp) .and. any(need_mu(star(:)%isoftcore))) call read_inopt(gmw,'mu',db,min=0.,errcount=nerr) + case(10,20) + if (ieos==20) call read_inopt(irecomb,'irecomb',db,errcount=nerr) + ! if softening stellar core, composition is automatically determined at R/2 + if ( (.not. use_var_comp) .and. any(need_mu(star(:)%isoftcore))) then + call read_inopt(X_in,'X',db,min=0.,max=1.,errcount=nerr) + call read_inopt(Z_in,'Z',db,min=0.,max=1.,errcount=nerr) + endif + end select + +end subroutine read_options_stars_eos + end module setstar diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index a82a1be51..449c4eecc 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -49,7 +49,7 @@ module setstar_utils public :: set_star_thermalenergy public :: set_stellar_core public :: write_kepler_comp - public :: need_inputprofile,need_polyk,need_rstar + public :: need_inputprofile,need_polyk,need_rstar,need_mu public :: get_mass_coord private @@ -199,7 +199,7 @@ end function need_inputprofile ! polytropic constant !+ !------------------------------------------------------------------------------- -logical function need_polyk(iprofile) +logical elemental function need_polyk(iprofile) integer, intent(in) :: iprofile select case(iprofile) @@ -211,6 +211,18 @@ logical function need_polyk(iprofile) end function need_polyk +!------------------------------------------------------------------------------- +!+ +! query function for whether mean molecular weight is needed +!+ +!------------------------------------------------------------------------------- +logical elemental function need_mu(isoftcore) + integer, intent(in) :: isoftcore + + need_mu = (isoftcore <= 0) + +end function need_mu + !------------------------------------------------------------------------------- !+ ! query function for whether a particular profile needs to read the @@ -359,7 +371,7 @@ subroutine get_mass_coord(i1,npart,xyzh,mass_enclosed_r) allocate(mass_enclosed_r(npart-i1),iorder(npart-i1)) ! sort particles by radius - call sort_by_radius(npart-i1,xyzh(1:3,i1+1:npart),iorder) + call sort_by_radius(npart-i1,xyzh(:,i1+1:npart),iorder) ! calculate cumulative mass massri = 0. diff --git a/src/setup/set_units.f90 b/src/setup/set_units.f90 index 5c6de9e7e..218eedae7 100644 --- a/src/setup/set_units.f90 +++ b/src/setup/set_units.f90 @@ -106,8 +106,8 @@ subroutine read_options_units(db,umass,udist,nerr,gr) if (present(gr)) nogr = .not.gr ! units - call read_inopt(mass_unit,'mass_unit',db,errcount=nerr) - if (nogr) call read_inopt(dist_unit,'dist_unit',db,errcount=nerr) + call read_inopt(mass_unit,'mass_unit',db,errcount=nerr,default=trim(mass_unit)) + if (nogr) call read_inopt(dist_unit,'dist_unit',db,errcount=nerr,default=trim(dist_unit)) ! ! parse units diff --git a/src/setup/setup_binary.f90 b/src/setup/setup_binary.f90 index f66acfae9..1291b6805 100644 --- a/src/setup/setup_binary.f90 +++ b/src/setup/setup_binary.f90 @@ -54,6 +54,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& use setunits, only:mass_unit,dist_unit use physcon, only:deg_to_rad use kernel, only:hfact_default + use units, only:in_code_units integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) @@ -67,6 +68,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& integer :: ierr,nstar,nptmass_in,iextern_prev logical :: iexist,write_profile,use_var_comp,add_spin real :: xyzmh_ptmass_in(nsinkproperties,2),vxyz_ptmass_in(3,2),angle + real :: m1,m2,hacc1,hacc2 logical, parameter :: set_oblateness = .false. ! !--general parameters @@ -75,7 +77,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& mass_unit = 'solarm' time = 0. polyk = 0. - gamma = 1. + gamma = 5./3. + ieos = 2 hfact = hfact_default ! !--space available for injected gas particles @@ -93,17 +96,18 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& call set_defaults_orbit(orbit) relax = .true. corotate = .false. - ieos = 2 + use_var_comp = .false. + write_profile = .false. if (id==master) print "(/,65('-'),1(/,a),/,65('-'),/)",& ' Welcome to the Ultimate Binary Setup' filename = trim(fileprefix)//'.setup' inquire(file=filename,exist=iexist) - if (iexist) call read_setupfile(filename,ieos,polyk,ierr) + if (iexist) call read_setupfile(filename,ieos,ierr) if (.not. iexist .or. ierr /= 0) then if (id==master) then - call write_setupfile(filename) + call write_setupfile(filename,ieos) print*,' Edit '//trim(filename)//' and rerun phantomsetup' endif stop @@ -111,24 +115,27 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& ! !--setup and relax stars as needed ! - use_var_comp = .false. - write_profile = .false. iextern_prev = iexternalforce iexternalforce = 0 - gamma = 5./3. call set_stars(id,master,nstar,star,xyzh,vxyzu,eos_vars,rad,npart,npartoftype,& - massoftype,hfact,xyzmh_ptmass,vxyz_ptmass,nptmass,ieos,polyk,gamma,& + massoftype,hfact,xyzmh_ptmass,vxyz_ptmass,nptmass,ieos,gamma,& X_in,Z_in,relax,use_var_comp,write_profile,& rhozero,npart_total,i_belong,ierr) nptmass_in = 0 + ! convert mass and accretion radii to code units + m1 = in_code_units(star(1)%m,ierr) + m2 = in_code_units(star(2)%m,ierr) + hacc1 = in_code_units(star(1)%hacc,ierr) + hacc2 = in_code_units(star(2)%hacc,ierr) + if (iextern_prev==iext_corotate) then - call set_orbit(orbit,star(1)%mstar,star(2)%mstar,star(1)%hacc,star(2)%hacc,& - xyzmh_ptmass_in,vxyz_ptmass_in,nptmass_in,(id==master),ierr,omega_corotate) + call set_orbit(orbit,m1,m2,hacc1,hacc2,xyzmh_ptmass_in,vxyz_ptmass_in,& + nptmass_in,(id==master),ierr,omega_corotate) add_spin = .false. else - call set_orbit(orbit,star(1)%mstar,star(2)%mstar,star(1)%hacc,star(2)%hacc,& - xyzmh_ptmass_in,vxyz_ptmass_in,nptmass_in,(id==master),ierr) + call set_orbit(orbit,m1,m2,hacc1,hacc2,xyzmh_ptmass_in,vxyz_ptmass_in,& + nptmass_in,(id==master),ierr) add_spin = corotate endif if (ierr /= 0) call fatal ('setup_binary','error in call to set_orbit') @@ -167,12 +174,13 @@ end subroutine setpart ! write options to .setup file !+ !---------------------------------------------------------------- -subroutine write_setupfile(filename) +subroutine write_setupfile(filename,ieos) use infile_utils, only:write_inopt use setstar, only:write_options_stars use setorbit, only:write_options_orbit use setunits, only:write_options_units character(len=*), intent(in) :: filename + integer, intent(in) :: ieos integer :: iunit print "(a)",' writing setup options file '//trim(filename) @@ -180,7 +188,7 @@ subroutine write_setupfile(filename) write(iunit,"(a)") '# input file for binary setup routines' call write_options_units(iunit,gr) - call write_options_stars(star,relax,iunit) + call write_options_stars(star,relax,ieos,iunit) call write_inopt(corotate,'corotate','set stars in corotation',iunit) call write_options_orbit(orbit,iunit) close(iunit) @@ -192,7 +200,7 @@ end subroutine write_setupfile ! read options from .setup file !+ !---------------------------------------------------------------- -subroutine read_setupfile(filename,ieos,polyk,ierr) +subroutine read_setupfile(filename,ieos,ierr) use infile_utils, only:open_db_from_file,inopts,read_inopt,close_db use io, only:error,fatal use setstar, only:read_options_stars @@ -200,7 +208,6 @@ subroutine read_setupfile(filename,ieos,polyk,ierr) use setunits, only:read_options_and_set_units character(len=*), intent(in) :: filename integer, intent(inout) :: ieos - real, intent(inout) :: polyk integer, intent(out) :: ierr integer, parameter :: iunit = 21 integer :: nerr,need_iso @@ -210,7 +217,7 @@ subroutine read_setupfile(filename,ieos,polyk,ierr) ierr = 0 call open_db_from_file(db,filename,iunit,ierr) call read_options_and_set_units(db,nerr,gr) - call read_options_stars(star,need_iso,ieos,polyk,relax,db,nerr) + call read_options_stars(star,need_iso,ieos,relax,db,nerr) if (need_iso==1) call fatal('setup_binary','incompatible setup for eos') call read_inopt(corotate,'corotate',db,errcount=nerr) call read_options_orbit(orbit,db,nerr) diff --git a/src/setup/setup_star.f90 b/src/setup/setup_star.f90 index 26c310081..1a11292f3 100644 --- a/src/setup/setup_star.f90 +++ b/src/setup/setup_star.f90 @@ -50,7 +50,7 @@ module setup real :: maxvxyzu logical :: iexist logical :: relax_star_in_setup,write_rho_to_file - type(star_t) :: star + type(star_t) :: star(1) public :: setpart private @@ -125,7 +125,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, setupfile = trim(fileprefix)//'.setup' inquire(file=setupfile,exist=setexists) if (setexists) then - call read_setupfile(setupfile,gamma,polyk,need_iso,ierr) + call read_setupfile(setupfile,gamma,need_iso,ierr) if (ierr /= 0) then if (id==master) call write_setupfile(setupfile,gamma,polyk) stop 'please rerun phantomsetup with revised .setup file' @@ -133,7 +133,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, !--Prompt to get inputs and write to file elseif (id==master) then print "(a,/)",trim(setupfile)//' not found: using interactive setup' - call setup_interactive(polyk,gamma,iexist,id,master,ierr) + call setup_interactive(gamma,iexist,id,master,ierr) call write_setupfile(setupfile,gamma,polyk) stop 'please check and edit .setup file and rerun phantomsetup' endif @@ -161,8 +161,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, npart = 0 nptmass = 0 vxyzu = 0.0 - call set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,npart,npartoftype,& - massoftype,hfact,xyzmh_ptmass,vxyz_ptmass,nptmass,ieos,polyk,gamma,& + call set_star(id,master,star(1),xyzh,vxyzu,eos_vars,rad,npart,npartoftype,& + massoftype,hfact,xyzmh_ptmass,vxyz_ptmass,nptmass,ieos,gamma,& X_in,Z_in,relax_star_in_setup,use_var_comp,write_rho_to_file,& rhozero,npart_total,i_belong,ierr) ! @@ -173,7 +173,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! ! override some default settings in the .in file for some cases ! - select case(star%iprofile) + select case(star(1)%iprofile) case(ibpwpoly) ! piecewise polytrope calc_erot = .true. case(ievrard) ! Evrard Collapse @@ -191,14 +191,14 @@ end subroutine setpart ! Ask questions of the user to determine which setup to use !+ !----------------------------------------------------------------------- -subroutine setup_interactive(polyk,gamma,iexist,id,master,ierr) +subroutine setup_interactive(gamma,iexist,id,master,ierr) use prompting, only:prompt use units, only:select_unit use eos, only:X_in,Z_in,gmw use eos_gasradrec, only:irecomb use setstar, only:set_star_interactive use setunits, only:set_units_interactive - real, intent(out) :: polyk,gamma + real, intent(out) :: gamma logical, intent(in) :: iexist integer, intent(in) :: id,master integer, intent(out) :: ierr @@ -209,35 +209,29 @@ subroutine setup_interactive(polyk,gamma,iexist,id,master,ierr) call set_units_interactive(gr) ! star - call set_star_interactive(id,master,star,need_iso,use_var_comp,ieos,polyk) - - ! equation of state - call prompt('Enter the desired EoS (1=isothermal,2=adiabatic,10=MESA,12=idealplusrad)',ieos) - select case(ieos) - case(15) ! Helmholtz - call prompt('Enter temperature',star%initialtemp,1.0e3,1.0e11) - case(9) - write(*,'(a)') 'EOS options: 1=APR3,2=SLy,3=MS1,4=ENG (from Read et al 2009)' - call prompt('Enter equation of state type',EOSopt,1,4) - case(2) - call prompt('Enter gamma (adiabatic index)',gamma,1.,7.) - case(20) - call prompt('Enter irecomb (0: H2+H+He, 1:H+He, 2:He)',irecomb,0) - end select - - if (need_polyk(star%iprofile)) then - call prompt('Enter polytropic constant (cs^2 if isothermal)',polyk,0.) - endif - - if ((.not. use_var_comp) .and. (star%isoftcore<=0)) then - if ( (ieos==12) .or. (ieos==2) ) call prompt('Enter mean molecular weight',gmw,0.) - if ( (ieos==10) .or. (ieos==20) ) then - call prompt('Enter hydrogen mass fraction (X)',X_in,0.,1.) - call prompt('Enter metals mass fraction (Z)',Z_in,0.,1.) - endif - endif - - call prompt('Relax star automatically during setup?',relax_star_in_setup) + !call set_star_interactive(id,master,star,need_iso,use_var_comp,ieos) + +! ! equation of state +! call prompt('Enter the desired EoS (1=isothermal,2=adiabatic,10=MESA,12=idealplusrad)',ieos) +! select case(ieos) +! case(9) +! write(*,'(a)') 'EOS options: 1=APR3,2=SLy,3=MS1,4=ENG (from Read et al 2009)' +! call prompt('Enter equation of state type',EOSopt,1,4) +! case(2) +! call prompt('Enter gamma (adiabatic index)',gamma,1.,7.) +! case(20) +! call prompt('Enter irecomb (0: H2+H+He, 1:H+He, 2:He)',irecomb,0) +! end select + +! if ((.not. use_var_comp) .and. (star%isoftcore<=0)) then +! if ( (ieos==12) .or. (ieos==2) ) call prompt('Enter mean molecular weight',gmw,0.) +! if ( (ieos==10) .or. (ieos==20) ) then +! call prompt('Enter hydrogen mass fraction (X)',X_in,0.,1.) +! call prompt('Enter metals mass fraction (Z)',Z_in,0.,1.) +! endif +! endif + +! call prompt('Relax star automatically during setup?',relax_star_in_setup) end subroutine setup_interactive @@ -250,9 +244,9 @@ subroutine write_setupfile(filename,gamma,polyk) use infile_utils, only:write_inopt use dim, only:tagline,use_apr use relaxstar, only:write_options_relax - use eos, only:X_in,Z_in,gmw + use eos, only:ieos use eos_gasradrec, only:irecomb - use setstar, only:write_options_star,need_polyk + use setstar, only:write_options_stars,need_polyk use setunits, only:write_options_units use apr, only:write_options_apr real, intent(in) :: gamma,polyk @@ -265,40 +259,38 @@ subroutine write_setupfile(filename,gamma,polyk) write(iunit,"(a)") '# input file for Phantom star setup' call write_options_units(iunit,gr) - call write_options_star(star,iunit) - - write(iunit,"(/,a)") '# equation of state' - call write_inopt(ieos,'ieos','1=isothermal,2=adiabatic,10=MESA,12=idealplusrad',iunit) - - if (star%iprofile==imesa) then - call write_inopt(use_var_comp,'use_var_comp','Use variable composition (X, Z, mu)',iunit) - endif - - select case(ieos) - case(15) ! Helmholtz - call write_inopt(star%initialtemp,'initialtemp','initial temperature of the star',iunit) - case(9) - write(iunit,"(/,a)") '# Piecewise Polytrope default options' - call write_inopt(EOSopt,'EOSopt','EOS: 1=APR3,2=SLy,3=MS1,4=ENG (from Read et al 2009)',iunit) - case(2) - call write_inopt(gamma,'gamma','Adiabatic index',iunit) - if ((star%isoftcore<=0) .and. (.not. use_var_comp)) call write_inopt(gmw,'mu','mean molecular weight',iunit) - case(10,20) - if (ieos==20) call write_inopt(irecomb,'irecomb','Species to include in recombination (0: H2+H+He, 1:H+He, 2:He',iunit) - if ( (.not. use_var_comp) .and. (star%isoftcore <= 0) ) then - call write_inopt(X_in,'X','hydrogen mass fraction',iunit) - call write_inopt(Z_in,'Z','metallicity',iunit) - endif - case(12) - call write_inopt(gamma,'gamma','Adiabatic index',iunit) - if ((star%isoftcore<=0) .and. (.not. use_var_comp)) call write_inopt(gmw,'mu','mean molecular weight',iunit) - end select - - if (need_polyk(star%iprofile)) call write_inopt(polyk,'polyk','polytropic constant (cs^2 if isothermal)',iunit) - - write(iunit,"(/,a)") '# relaxation options' - call write_inopt(relax_star_in_setup,'relax_star','relax star(s) automatically during setup',iunit) - if (relax_star_in_setup) call write_options_relax(iunit) + call write_options_stars(star,relax_star_in_setup,ieos,iunit) + + !write(iunit,"(/,a)") '# equation of state' + !call write_inopt(ieos,'ieos','1=isothermal,2=adiabatic,10=MESA,12=idealplusrad',iunit) + + !if (star%iprofile==imesa) then + ! call write_inopt(use_var_comp,'use_var_comp','Use variable composition (X, Z, mu)',iunit) + !endif + + !select case(ieos) + !case(15) ! Helmholtz + ! call write_inopt(star%initialtemp,'initialtemp','initial temperature of the star',iunit) + !case(9) + ! write(iunit,"(/,a)") '# Piecewise Polytrope default options' + ! call write_inopt(EOSopt,'EOSopt','EOS: 1=APR3,2=SLy,3=MS1,4=ENG (from Read et al 2009)',iunit) + !case(2) + ! call write_inopt(gamma,'gamma','Adiabatic index',iunit) + ! if ((star%isoftcore<=0) .and. (.not. use_var_comp)) call write_inopt(gmw,'mu','mean molecular weight',iunit) + !case(10,20) + ! if (ieos==20) call write_inopt(irecomb,'irecomb','Species to include in recombination (0: H2+H+He, 1:H+He, 2:He',iunit) + ! if ( (.not. use_var_comp) .and. (star%isoftcore <= 0) ) then + ! call write_inopt(X_in,'X','hydrogen mass fraction',iunit) + ! call write_inopt(Z_in,'Z','metallicity',iunit) + ! endif + !case(12) + ! call write_inopt(gamma,'gamma','Adiabatic index',iunit) + ! if ((star%isoftcore<=0) .and. (.not. use_var_comp)) call write_inopt(gmw,'mu','mean molecular weight',iunit) + !end select + + !write(iunit,"(/,a)") '# relaxation options' + !call write_inopt(relax_star_in_setup,'relax_star','relax star(s) automatically during setup',iunit) + !if (relax_star_in_setup) call write_options_relax(iunit) call write_inopt(write_rho_to_file,'write_rho_to_file','write density profile(s) to file',iunit) @@ -312,21 +304,21 @@ end subroutine write_setupfile ! Read setup parameters from input file !+ !----------------------------------------------------------------------- -subroutine read_setupfile(filename,gamma,polyk,need_iso,ierr) +subroutine read_setupfile(filename,gamma,need_iso,ierr) use infile_utils, only:open_db_from_file,inopts,close_db,read_inopt use io, only:error use units, only:select_unit use relaxstar, only:read_options_relax - use eos, only:X_in,Z_in,gmw + use eos, only:X_in,Z_in,gmw,ieos use eos_gasradrec, only:irecomb - use setstar, only:read_options_star + use setstar, only:read_options_stars use setunits, only:read_options_and_set_units use apr, only:apr_max_in,ref_dir,apr_type,apr_rad,apr_drad use dim, only:use_apr character(len=*), intent(in) :: filename integer, parameter :: lu = 21 integer, intent(out) :: need_iso,ierr - real, intent(out) :: gamma,polyk + real, intent(out) :: gamma integer :: nerr type(inopts), allocatable :: db(:) @@ -339,39 +331,39 @@ subroutine read_setupfile(filename,gamma,polyk,need_iso,ierr) call read_options_and_set_units(db,nerr,gr) ! star options - call read_options_star(star,need_iso,ieos,polyk,db,nerr) - - ! equation of state - call read_inopt(ieos,'ieos',db,errcount=nerr) - if (star%iprofile==imesa) call read_inopt(use_var_comp,'use_var_comp',db,errcount=nerr) - - select case(ieos) - case(15) ! Helmholtz - call read_inopt(star%initialtemp,'initialtemp',db,errcount=nerr) - case(9) - call read_inopt(EOSopt,'EOSopt',db,errcount=nerr) - case(2) - call read_inopt(gamma,'gamma',db,errcount=nerr) - if ( (.not. use_var_comp) .and. (star%isoftcore <= 0)) call read_inopt(gmw,'mu',db,errcount=nerr) - case(10,20) - if (ieos==20) call read_inopt(irecomb,'irecomb',db,errcount=nerr) - ! if softening stellar core, composition is automatically determined at R/2 - if ( (.not. use_var_comp) .and. (star%isoftcore <= 0)) then - call read_inopt(X_in,'X',db,errcount=nerr) - call read_inopt(Z_in,'Z',db,errcount=nerr) - endif - case(12) + call read_options_stars(star,need_iso,ieos,relax_star_in_setup,db,nerr) + + !! equation of state + !call read_inopt(ieos,'ieos',db,errcount=nerr) + !if (star%iprofile==imesa) call read_inopt(use_var_comp,'use_var_comp',db,errcount=nerr) + + !select case(ieos) + !case(15) ! Helmholtz + ! call read_inopt(star%initialtemp,'initialtemp',db,errcount=nerr) + !case(9) + ! call read_inopt(EOSopt,'EOSopt',db,errcount=nerr) + !case(2) + ! call read_inopt(gamma,'gamma',db,errcount=nerr) + ! if ( (.not. use_var_comp) .and. (star%isoftcore <= 0)) call read_inopt(gmw,'mu',db,errcount=nerr) + !case(10,20) + ! if (ieos==20) call read_inopt(irecomb,'irecomb',db,errcount=nerr) + ! ! if softening stellar core, composition is automatically determined at R/2 + ! if ( (.not. use_var_comp) .and. (star%isoftcore <= 0)) then + ! call read_inopt(X_in,'X',db,errcount=nerr) + ! call read_inopt(Z_in,'Z',db,errcount=nerr) + ! endif + !case(12) ! if softening stellar core, mu is automatically determined at R/2 - call read_inopt(gamma,'gamma',db,errcount=nerr) - if ( (.not. use_var_comp) .and. (star%isoftcore <= 0)) call read_inopt(gmw,'mu',db,errcount=nerr) - end select + ! call read_inopt(gamma,'gamma',db,errcount=nerr) + ! if ( (.not. use_var_comp) .and. (star%isoftcore <= 0)) call read_inopt(gmw,'mu',db,errcount=nerr) +! end select - if (need_polyk(star%iprofile)) call read_inopt(polyk,'polyk',db,errcount=nerr) + !if (need_polyk(star%iprofile)) call read_inopt(polyk,'polyk',db,errcount=nerr) ! relax star options - call read_inopt(relax_star_in_setup,'relax_star',db,errcount=nerr) - if (relax_star_in_setup) call read_options_relax(db,nerr) - if (nerr /= 0) ierr = ierr + 1 + !call read_inopt(relax_star_in_setup,'relax_star',db,errcount=nerr) + !if (relax_star_in_setup) call read_options_relax(db,nerr)! + !if (nerr /= 0) ierr = ierr + 1 ! option to write density profile to file call read_inopt(write_rho_to_file,'write_rho_to_file',db) From 7ed2c3f77096ff7eafd14b3740f471e382b68eb1 Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 2 Dec 2024 17:31:15 +0100 Subject: [PATCH 107/134] (substepping) reorganize substep and get_force routine for clarity --- src/main/evolve.F90 | 7 +- src/main/initial.F90 | 21 ++-- src/main/ptmass.F90 | 46 ++++----- src/main/substepping.F90 | 217 +++++++++++++++------------------------ 4 files changed, 107 insertions(+), 184 deletions(-) diff --git a/src/main/evolve.F90 b/src/main/evolve.F90 index 16d45adc2..b899b6d5a 100644 --- a/src/main/evolve.F90 +++ b/src/main/evolve.F90 @@ -333,12 +333,9 @@ subroutine evol(infile,logfile,evfile,dumpfile,flag) if (use_regnbody) then call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,bin_info,nmatrix,& new_ptmass=.true.,dtext=dtextforce) - call get_force(nptmass,npart,0,1,time,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,& - fxyz_ptmass,dsdt_ptmass,0.,0.,dummy,.false.,linklist_ptmass,bin_info,group_info=group_info) - else - call get_force(nptmass,npart,0,1,time,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,& - fxyz_ptmass,dsdt_ptmass,0.,0.,dummy,.false.,linklist_ptmass,bin_info) endif + call get_force(nptmass,npart,0,1,time,dtextforce,xyzh,vxyzu,fext,xyzmh_ptmass,vxyz_ptmass,& + fxyz_ptmass,dsdt_ptmass,0.,0.,dummy,.false.,linklist_ptmass,bin_info,group_info) if (ipart_createseeds /= 0) ipart_createseeds = 0 ! reset pointer to zero if (ipart_createstars /= 0) ipart_createstars = 0 ! reset pointer to zero dummy = 0 diff --git a/src/main/initial.F90 b/src/main/initial.F90 index aaeb33633..67b480e15 100644 --- a/src/main/initial.F90 +++ b/src/main/initial.F90 @@ -529,14 +529,10 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) if (use_regnbody) then call init_subgroup call group_identify(nptmass,n_group,n_ingroup,n_sing,xyzmh_ptmass,vxyz_ptmass,group_info,bin_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,bin_info=bin_info) - - else - call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,dtsinksink,& - iexternalforce,time,merge_ij,merge_n,dsdt_ptmass) endif + call get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,epot_sinksink,dtsinksink,& + iexternalforce,time,merge_ij,merge_n,dsdt_ptmass,& + group_info,bin_info) dtsinksink = C_force*dtsinksink if (id==master) write(iprint,*) 'dt(sink-sink) = ',dtsinksink dtextforce = min(dtextforce,dtsinksink) @@ -555,14 +551,9 @@ subroutine startrun(infile,logfile,evfile,dumpfile,noread) elseif (use_apr) then pmassi = aprmassoftype(igas,apr_level(i)) endif - if (use_regnbody) then - call get_accel_sink_gas(nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),xyzmh_ptmass, & - fext(1,i),fext(2,i),fext(3,i),poti,pmassi,fxyz_ptmass,& - dsdt_ptmass,fonrmax,dtphi2,bin_info=bin_info) - else - call get_accel_sink_gas(nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),xyzmh_ptmass, & - fext(1,i),fext(2,i),fext(3,i),poti,pmassi,fxyz_ptmass,dsdt_ptmass,fonrmax,dtphi2) - endif + call get_accel_sink_gas(nptmass,xyzh(1,i),xyzh(2,i),xyzh(3,i),xyzh(4,i),xyzmh_ptmass, & + fext(1,i),fext(2,i),fext(3,i),poti,pmassi,fxyz_ptmass,& + dsdt_ptmass,fonrmax,dtphi2,bin_info) dtsinkgas = min(dtsinkgas,C_force*1./sqrt(fonrmax),C_force*sqrt(dtphi2)) endif enddo diff --git a/src/main/ptmass.F90 b/src/main/ptmass.F90 index b0a148042..4f4c9f995 100644 --- a/src/main/ptmass.F90 +++ b/src/main/ptmass.F90 @@ -150,8 +150,7 @@ module ptmass !+ !---------------------------------------------------------------- subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, & - pmassi,fxyz_ptmass,dsdt_ptmass,fonrmax, & - dtphi2,extrapfac,fsink_old,bin_info) + pmassi,fxyz_ptmass,dsdt_ptmass,fonrmax,dtphi2,bin_info,extrapfac,fsink_old) #ifdef FINVSQRT use fastmath, only:finvsqrt #endif @@ -165,15 +164,15 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, real, intent(in) :: xyzmh_ptmass(nsinkproperties,nptmass) real, optional, intent(in) :: pmassi,extrapfac real, optional, intent(inout) :: fxyz_ptmass(4,nptmass),dsdt_ptmass(3,nptmass) - real, optional, intent(inout) :: bin_info(6,nptmass) real, optional, intent(in) :: fsink_old(4,nptmass) real, optional, intent(out) :: fonrmax,dtphi2 + real, optional, intent(inout) :: bin_info(6,nptmass) real :: ftmpxi,ftmpyi,ftmpzi real :: dx,dy,dz,rr2,ddr,dr3,f1,f2,pmassj,J2,shat(3),Rsink real :: hsoft,hsoft1,hsoft21,q2i,qi,psoft,fsoft real :: fxj,fyj,fzj,dsx,dsy,dsz,fac,r integer :: j - logical :: tofrom,extrap,kappa + logical :: tofrom,extrap ! ! Determine if acceleration is from/to gas, or to gas ! @@ -191,12 +190,6 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, extrap = .false. endif - if (present(bin_info)) then - kappa = .true. - else - kappa = .false. - endif - ftmpxi = 0. ! use temporary summation variable ftmpyi = 0. ! (better for round-off, plus we need this bit of @@ -303,7 +296,7 @@ subroutine get_accel_sink_gas(nptmass,xi,yi,zi,hi,xyzmh_ptmass,fxi,fyi,fzi,phi, ! timestep is sqrt(separation/force) fonrmax = max(f1,f2,fonrmax) - if (kappa) then + if (use_regnbody) then if (abs(bin_info(isemi,j))>tiny(f2)) then bin_info(ipert,j) = bin_info(ipert,j) + f2 endif @@ -338,8 +331,8 @@ 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,extrapfac,fsink_old,& - group_info,bin_info) + iexternalforce,ti,merge_ij,merge_n,dsdt_ptmass,group_info,bin_info,& + extrapfac,fsink_old) #ifdef FINVSQRT use fastmath, only:finvsqrt #endif @@ -356,10 +349,10 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin real, intent(in) :: ti integer, intent(out) :: merge_ij(:),merge_n real, intent(out) :: dsdt_ptmass(3,nptmass) + integer, optional, intent(in) :: group_info(4,nptmass) + real, optional, intent(out) :: bin_info(6,nptmass) real, optional, intent(in) :: extrapfac real, optional, intent(in) :: fsink_old(4,nptmass) - real, optional, intent(out) :: bin_info(6,nptmass) - integer, optional, intent(in) :: group_info(4,nptmass) real :: xi,yi,zi,pmassi,pmassj,hacci,haccj,fxi,fyi,fzi,phii real :: ddr,dx,dy,dz,rr2,rr2j,dr3,f1,f2 real :: hsoft1,hsoft21,q2i,qi,psoft,fsoft @@ -368,7 +361,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin real :: J2i,rsinki,shati(3) real :: J2j,rsinkj,shatj(3) integer :: k,l,i,j,gidi,gidj,compi - logical :: extrap,subsys + logical :: extrap dtsinksink = huge(dtsinksink) fxyz_ptmass(:,:) = 0. @@ -376,6 +369,8 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin phitot = 0. merge_n = 0 merge_ij = 0 + gidi = 0 + gidj = 0 if (nptmass <= 0) return ! check if it is a force computed using Omelyan extrapolation method for FSI if (present(extrapfac) .and. present(fsink_old)) then @@ -384,11 +379,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin extrap = .false. endif - if (present(group_info) .and. present(bin_info)) then - subsys = .true. - else - subsys = .false. - endif + ! !--get self-contribution to the potential if sink-sink softening is used ! @@ -408,18 +399,19 @@ 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) & !$omp shared(iexternalforce,ti,h_soft_sinksink,potensoft0,hsoft1,hsoft21) & !$omp shared(extrapfac,extrap,fsink_old,h_acc,icreate_sinks) & - !$omp shared(group_info,bin_info,subsys) & + !$omp shared(group_info,bin_info,use_regnbody) & !$omp private(i,j,xi,yi,zi,pmassi,pmassj,hacci,haccj) & - !$omp private(gidi,gidj,compi,pert_out) & + !$omp private(compi,pert_out) & !$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) & !$omp private(q2i,qi,psoft,fsoft) & !$omp private(fterm,pterm,J2i,J2j,shati,shatj,rsinki,rsinkj) & + !$omp firstprivate(gidi,gidj)& !$omp reduction(min:dtsinksink) & !$omp reduction(+:phitot,merge_n) do k=1,nptmass - if (subsys) then + if (use_regnbody) then pert_out = 0. i = group_info(igarg,k) ! new id order when using group info gidi = group_info(igid,k) ! id of the group to identify which ptmasses are in the same group @@ -451,7 +443,7 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin dsy = 0. dsz = 0. do l=1,nptmass - if (subsys) then + if (use_regnbody) then j = group_info(igarg,l) gidj = group_info(igid,l) if (gidi==gidj) cycle @@ -551,13 +543,13 @@ subroutine get_accel_sink_sink(nptmass,xyzmh_ptmass,fxyz_ptmass,phitot,dtsinksin endif endif endif - if (subsys) then + if (use_regnbody) then if (compi /= i) pert_out = pert_out + f1 endif enddo phitot = phitot + 0.5*pmassi*phii ! total potential (G M_1 M_2/r) - if (subsys) bin_info(ipert,i) = pert_out + if (use_regnbody) bin_info(ipert,i) = pert_out ! !--apply external forces diff --git a/src/main/substepping.F90 b/src/main/substepping.F90 index f16a842d6..08f5d88a5 100644 --- a/src/main/substepping.F90 +++ b/src/main/substepping.F90 @@ -448,7 +448,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,ptmass_check_stars,icreate_sinks - use subgroup, only:group_identify,evolve_groups + use subgroup, only:group_identify integer, intent(in) :: npart,ntypes,nptmass integer, intent(inout) :: n_group,n_ingroup,n_sing integer, intent(inout) :: group_info(:,:) @@ -500,56 +500,33 @@ 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,dptmass) - if (use_regnbody) then - call evolve_groups(n_group,nptmass,time_par,time_par+ck(1)*dt,group_info,bin_info, & - xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + call drift(ck(1),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,& + vxyzu,vxyz_ptmass,fxyz_ptmass,gtgrad,n_group,n_ingroup,& + group_info,bin_info) - 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,linklist_ptmass,& - bin_info,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,linklist_ptmass,& - bin_info,isionised=isionised) - endif + 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,linklist_ptmass,& + bin_info,group_info,isionised=isionised) if (use_fourthorder) then !! FSI 4th order scheme ! FSI extrapolation method (Omelyan 2006) - 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,linklist_ptmass, & - bin_info,fsink_old,group_info=group_info) - - call kick(dk(2),dt,npart,nptmass,ntypes,xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& - fext,fxyz_ptmass,dsdt_ptmass,dptmass) + 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,linklist_ptmass, & + bin_info,group_info,fsink_old) - call evolve_groups(n_group,nptmass,time_par,time_par+ck(2)*dt,group_info,bin_info, & - xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + 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,n_ingroup,group_info) + call drift(ck(2),dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,& + vxyzu,vxyz_ptmass,fxyz_ptmass,gtgrad,n_group,n_ingroup,& + group_info,bin_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,linklist_ptmass, & - bin_info,group_info=group_info,isionised=isionised) - 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,linklist_ptmass,& - bin_info,fsink_old) - 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) + 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,linklist_ptmass, & + bin_info,group_info,isionised=isionised) - 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,linklist_ptmass,& - bin_info,isionised=isionised) - ! the last kick phase of the scheme will perform the accretion loop after velocity update - endif + ! 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, & @@ -560,11 +537,11 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & dtext=dtextforce) 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,linklist_ptmass, & - bin_info,group_info=group_info) + bin_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,linklist_ptmass,& - bin_info) + bin_info,group_info) endif else !! standard leapfrog scheme ! the last kick phase of the scheme will perform the accretion loop after velocity update @@ -574,7 +551,7 @@ subroutine substep(npart,ntypes,nptmass,dtsph,dtextforce,time,xyzh,vxyzu,fext, & if (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(2),force_count,extf_vdep_flag,linklist_ptmass,& - bin_info) + bin_info,group_info) endif endif @@ -610,18 +587,22 @@ end subroutine substep !+ !---------------------------------------------------------------- -subroutine drift(cki,dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vxyz_ptmass,n_ingroup,group_info) +subroutine drift(cki,dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu, & + vxyz_ptmass,fxyz_ptmass,gtgrad,n_group,n_ingroup,group_info, & + bin_info) use part, only: isdead_or_accreted,ispinx,ispiny,ispinz,igarg - use ptmass, only:ptmass_drift + use ptmass, only:ptmass_drift,use_regnbody + use subgroup, only:evolve_groups use io , only:id,master use mpiutils, only:bcast_mpi - real, intent(in) :: dt,cki - integer, intent(in) :: npart,nptmass,ntypes - real, intent(inout) :: time_par - real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) - integer, optional, intent(in) :: n_ingroup - integer, optional, intent(in) :: group_info(:,:) + real, intent(in) :: dt,cki + integer, intent(in) :: npart,nptmass,ntypes + real, intent(inout) :: time_par + real, intent(inout) :: xyzh(:,:),vxyzu(:,:) + real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) + real, intent(inout) :: fxyz_ptmass(:,:),gtgrad(:,:),bin_info(:,:) + integer, intent(in) :: n_ingroup,n_group + integer, intent(inout) :: group_info(:,:) integer :: i real :: ckdt @@ -644,7 +625,7 @@ subroutine drift(cki,dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vx ! Drift sink particles if (nptmass>0) then if (id==master) then - if (present(n_ingroup)) then + if (use_regnbody) then call ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass,group_info,n_ingroup) else call ptmass_drift(nptmass,ckdt,xyzmh_ptmass,vxyz_ptmass) @@ -653,6 +634,11 @@ subroutine drift(cki,dt,time_par,npart,nptmass,ntypes,xyzh,xyzmh_ptmass,vxyzu,vx call bcast_mpi(xyzmh_ptmass(:,1:nptmass)) endif + if (use_regnbody) then + call evolve_groups(n_group,nptmass,time_par,time_par+cki*dt,group_info,bin_info, & + xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,gtgrad) + endif + time_par = time_par + ckdt !! update time for external potential in force routine end subroutine drift @@ -860,8 +846,8 @@ end subroutine kick !---------------------------------------------------------------- subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, & fext,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,dsdt_ptmass,dt,dki, & - force_count,extf_vdep_flag,linklist_ptmass,bin_info,fsink_old,& - group_info,isionised) + force_count,extf_vdep_flag,linklist_ptmass,bin_info,group_info,& + fsink_old,isionised) use io, only:iverbose,master,id,iprint,warning,fatal use dim, only:maxp,maxvxyzu,itau_alloc,use_apr use ptmass, only:get_accel_sink_gas,get_accel_sink_sink,merge_sinks, & @@ -886,8 +872,8 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, real, intent(in) :: timei,dki,dt logical, intent(in) :: extf_vdep_flag real, intent(inout) :: bin_info(:,:) + integer, intent(in) :: group_info(:,:) real, optional, intent(inout) :: fsink_old(4,nptmass) - integer, optional, intent(in) :: group_info(:,:) logical, optional, intent(in) :: isionised(:) integer :: merge_ij(nptmass) integer :: merge_n @@ -897,7 +883,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,wsub + logical :: extrap,last if (present(fsink_old)) then fsink_old = fxyz_ptmass @@ -906,13 +892,6 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, extrap = .false. endif - if (present(group_info)) then - wsub = .true. - else - wsub = .false. - endif - - force_count = force_count + 1 extrapfac = (1./24.)*dt**2 dkdt = dki*dt @@ -935,54 +914,31 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, if (nptmass > 0) then if (id==master) then if (extrap) then - 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,bin_info,extrapfac,fsink_old) + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,linklist_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,bin_info) - if (merge_n > 0) then - call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,linklist_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,bin_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,linklist_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 + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass, & + group_info,bin_info,extrapfac,fsink_old) endif 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,bin_info) + if (merge_n > 0) then + call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,linklist_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,bin_info=bin_info) - if (merge_n > 0) then - call merge_sinks(timei,nptmass,xyzmh_ptmass,vxyz_ptmass,fxyz_ptmass,linklist_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,bin_info=bin_info) - endif - if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf - fxyz_ptmass_sinksink(:,1:nptmass) = fxyz_ptmass (:,1:nptmass) - dsdt_ptmass_sinksink(:,1:nptmass) = dsdt_ptmass (:,1:nptmass) - 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,linklist_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 - if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf - fxyz_ptmass_sinksink(:,1:nptmass) = fxyz_ptmass (:,1:nptmass) - dsdt_ptmass_sinksink(:,1:nptmass) = dsdt_ptmass (:,1:nptmass) + dtf,iexternalforce,timei,merge_ij,merge_n,dsdt_ptmass, & + group_info,bin_info) endif endif + if (iverbose >= 2) write(iprint,*) 'dt(sink-sink) = ',C_force*dtf + if (last) then + fxyz_ptmass_sinksink(:,1:nptmass) = fxyz_ptmass (:,1:nptmass) + dsdt_ptmass_sinksink(:,1:nptmass) = dsdt_ptmass (:,1:nptmass) + endif else fxyz_ptmass(:,1:nptmass) = 0. dsdt_ptmass(:,1:nptmass) = 0. @@ -997,7 +953,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, ! !$omp parallel default(none) & - !$omp shared(maxp,maxphase,wsub) & + !$omp shared(maxp,maxphase) & !$omp shared(npart,nptmass,xyzh,vxyzu,xyzmh_ptmass,fext) & !$omp shared(eos_vars,dust_temp,idamp,damp_fac,abundance,iphase,ntypes,massoftype) & !$omp shared(dkdt,dt,timei,iexternalforce,extf_vdep_flag,last,aprmassoftype,apr_level) & @@ -1034,30 +990,17 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, zi = xyzh(3,i) endif if (nptmass > 0) then - if (wsub) then - if (extrap) then - call get_accel_sink_gas(nptmass,xi,yi,zi,xyzh(4,i),xyzmh_ptmass,& + if (extrap) then + call get_accel_sink_gas(nptmass,xi,yi,zi,xyzh(4,i),xyzmh_ptmass,& fextx,fexty,fextz,phii,pmassi,fxyz_ptmass, & - dsdt_ptmass,fonrmaxi,dtphi2i,extrapfac,fsink_old,& - bin_info=bin_info) - else - call get_accel_sink_gas(nptmass,xi,yi,zi,xyzh(4,i),xyzmh_ptmass,& - fextx,fexty,fextz,phii,pmassi,fxyz_ptmass,dsdt_ptmass,fonrmaxi,dtphi2i,& - bin_info=bin_info) - fonrmax = max(fonrmax,fonrmaxi) - dtphi2 = min(dtphi2,dtphi2i) - endif + dsdt_ptmass,fonrmaxi,dtphi2i,bin_info,& + extrapfac,fsink_old) else - if (extrap) then - call get_accel_sink_gas(nptmass,xi,yi,zi,xyzh(4,i),xyzmh_ptmass,& - fextx,fexty,fextz,phii,pmassi,fxyz_ptmass, & - dsdt_ptmass,fonrmaxi,dtphi2i,extrapfac,fsink_old) - else - call get_accel_sink_gas(nptmass,xi,yi,zi,xyzh(4,i),xyzmh_ptmass,& - fextx,fexty,fextz,phii,pmassi,fxyz_ptmass,dsdt_ptmass,fonrmaxi,dtphi2i) - fonrmax = max(fonrmax,fonrmaxi) - dtphi2 = min(dtphi2,dtphi2i) - endif + call get_accel_sink_gas(nptmass,xi,yi,zi,xyzh(4,i),xyzmh_ptmass,& + fextx,fexty,fextz,phii,pmassi,fxyz_ptmass,& + dsdt_ptmass,fonrmaxi,dtphi2i,bin_info) + fonrmax = max(fonrmax,fonrmaxi) + dtphi2 = min(dtphi2,dtphi2i) endif endif @@ -1066,9 +1009,9 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, ! if (iexternalforce > 0) then call get_external_force_gas(xi,yi,zi,xyzh(4,i),vxyzu(1,i), & - vxyzu(2,i),vxyzu(3,i),timei,i, & - dtextforcenew,dtf,dkdt,fextx,fexty,fextz, & - extf_vdep_flag,iexternalforce) + vxyzu(2,i),vxyzu(3,i),timei,i, & + dtextforcenew,dtf,dkdt,fextx,fexty, & + fextz,extf_vdep_flag,iexternalforce) endif ! ! damping @@ -1083,10 +1026,10 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, if (extrap) then if (itau_alloc == 1) then call get_rad_accel_from_ptmass(nptmass,npart,i,xi,yi,zi,xyzmh_ptmass,fextx,fexty,fextz, & - tau=tau,fsink_old=fsink_old,extrapfac=extrapfac) + tau=tau,fsink_old=fsink_old,extrapfac=extrapfac) else call get_rad_accel_from_ptmass(nptmass,npart,i,xi,yi,zi,xyzmh_ptmass,fextx,fexty,fextz, & - fsink_old=fsink_old,extrapfac=extrapfac) + fsink_old=fsink_old,extrapfac=extrapfac) endif else if (itau_alloc == 1) then @@ -1105,7 +1048,7 @@ subroutine get_force(nptmass,npart,nsubsteps,ntypes,timei,dtextforce,xyzh,vxyzu, ! if (maxvxyzu >= 4 .and. itype==igas .and. last) then call cooling_abundances_update(i,pmassi,xyzh,vxyzu,eos_vars,abundance,nucleation,dust_temp, & - divcurlv,abundc,abunde,abundo,abundsi,dt,dphot0,isionised(i)) + divcurlv,abundc,abunde,abundo,abundsi,dt,dphot0,isionised(i)) endif endif enddo From 0b65f47b7c0878d2004130645892d24cfcf5538e Mon Sep 17 00:00:00 2001 From: Yrisch Date: Mon, 2 Dec 2024 17:32:29 +0100 Subject: [PATCH 108/134] (test_ptmass) fix eos initialisation in test_createsink if used with test_all --- src/tests/test_ptmass.f90 | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/tests/test_ptmass.f90 b/src/tests/test_ptmass.f90 index ce6751ab8..da7f7dac6 100644 --- a/src/tests/test_ptmass.f90 +++ b/src/tests/test_ptmass.f90 @@ -780,7 +780,9 @@ subroutine test_createsink(ntests,npass) use dim, only:gravity,maxp,maxphase use boundary, only:set_boundary use deriv, only:get_derivs_global + use eos, only:ieos,polyk use kdtree, only:tree_accuracy + use units, only:set_units use io, only:id,master,iverbose use part, only:init_part,npart,npartoftype,igas,xyzh,massoftype,hfact,rhoh,& iphase,isetphase,fext,divcurlv,vxyzu,fxyzu,poten, & @@ -801,10 +803,13 @@ subroutine test_createsink(ntests,npass) real :: etotin,angmomin,totmomin,rhomax,rhomax_test procedure(rho_func), pointer :: density_func + call set_units(mass=1.d0,dist=1.d0,G=1.d0) density_func => gaussianr t = 0. iverbose = 1 rho_crit = rho_crit_cgs + ieos = 1 + polyk = 0. do itest=1,3 select case(itest) @@ -822,6 +827,7 @@ subroutine test_createsink(ntests,npass) vxyzu(:,:) = 0. fxyzu(:,:) = 0. fext(:,:) = 0. + ! ! set a boundary that is larger than the sphere size, so test still works with periodic boundaries ! @@ -1318,6 +1324,7 @@ subroutine test_SDAR(ntests,npass) real :: fxyz_sinksink(4,3),dsdt_sinksink(3,3) ! we only use 3 sink particles in the tests here real :: xsec(3),vsec(3) real(kind=4) :: t1 + if (id==master) write(*,"(/,a)") '--> testing SDAR module : Kozai-Lidov effect' ! !--no gas particles ! From 245f2d2be81ea0acad73198bed752af7c70bb295 Mon Sep 17 00:00:00 2001 From: Kateryna Andrych Date: Wed, 4 Dec 2024 15:22:53 +1100 Subject: [PATCH 109/134] set isink=1for ieos=6 in case where isink was not set --- src/main/eos.f90 | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/main/eos.f90 b/src/main/eos.f90 index 5df8d12ca..59c4326c5 100644 --- a/src/main/eos.f90 +++ b/src/main/eos.f90 @@ -481,9 +481,8 @@ subroutine init_eos(eos_type,ierr) !--Check that if using ieos=6, then isink is set properly ! if (isink==0) then - call error('eos','ieos=6, but isink is not set') - ierr = ierr_isink_not_set - return + call error('eos','ieos=6, but isink is not set, setting to 1') + isink = 1 endif case(8) From 1a847eb3b93f7ace6120059d6d13298b478b252b Mon Sep 17 00:00:00 2001 From: Kateryna Andrych Date: Wed, 4 Dec 2024 15:50:34 +1100 Subject: [PATCH 110/134] does not override ieos to 3 for single disc in case where ieos==6 --- src/setup/setup_disc.f90 | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/src/setup/setup_disc.f90 b/src/setup/setup_disc.f90 index 590f8a2b4..171b7e404 100644 --- a/src/setup/setup_disc.f90 +++ b/src/setup/setup_disc.f90 @@ -687,6 +687,7 @@ subroutine equation_of_state(gamma) ieos = 6 print "(/,a)",' setting ieos=6 for locally isothermal disc around sink' else + isink = 0 if (discstrat > 0) then ieos = 7 print "(/,a)",' setting ieos=7 for locally isothermal disc with stratification' @@ -695,10 +696,15 @@ subroutine equation_of_state(gamma) polyk2 = (cs*(1./R_ref(onlydisc))**(-qfacdisc2))**2 z0 = z0_ref/R_ref(onlydisc)**beta_z else - ieos = 3 - print "(/,a)",' setting ieos=3 for locally isothermal disc around origin' + if (ieos == 6) then + ! handle the case where ieos=6 is already set in the .in file; do not override this + isink = 1 + print "(/,a)",' keeping ieos=6 for locally isothermal disc with bright primary' + else + ieos = 3 + print "(/,a)",' setting ieos=3 for locally isothermal disc around origin' + endif endif - isink = 0 ! In the case isink==3, to be generalized endif qfacdisc = qindex(onlydisc) endif From 269861aee0bcf86daf901c0818a4b31ec986538a Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 6 Dec 2024 14:36:20 +1100 Subject: [PATCH 111/134] (set_star) shift all functionality from setup_star into set_star; now includes eos, relax and apr options needed for one or more stars --- src/main/apr.f90 | 14 ++- src/setup/set_star.f90 | 137 ++++++++++++++++++++----- src/setup/setup_star.f90 | 204 +++++-------------------------------- src/tests/test_setstar.f90 | 3 +- 4 files changed, 145 insertions(+), 213 deletions(-) diff --git a/src/main/apr.f90 b/src/main/apr.f90 index 3adf55d70..b645ade72 100644 --- a/src/main/apr.f90 +++ b/src/main/apr.f90 @@ -24,10 +24,12 @@ module apr ! mpiforce, part, physcon, ptmass, quitdump, random, relaxem, ! timestep_ind, vectorutils ! + use dim, only:use_apr implicit none public :: init_apr,update_apr,read_options_apr,write_options_apr public :: create_or_update_apr_clump + public :: use_apr ! default values for runtime parameters integer, public :: apr_max_in = 3 @@ -56,7 +58,7 @@ module apr !+ !----------------------------------------------------------------------- subroutine init_apr(apr_level,ierr) - use dim, only:maxp_hard + use dim, only:maxp_hard use part, only:npart,massoftype,aprmassoftype use apr_region, only:set_apr_centre,set_apr_regions integer, intent(inout) :: ierr @@ -610,22 +612,26 @@ subroutine write_options_apr(iunit) call write_inopt(apr_max_in,'apr_max','number of additional refinement levels (3 -> 2x resolution)',iunit) call write_inopt(ref_dir,'ref_dir','increase (1) or decrease (-1) resolution',iunit) call write_inopt(apr_type,'apr_type','1: static, 2: moving sink, 3: create clumps',iunit) - select case (apr_type) + select case (apr_type) case(2) call write_inopt(track_part,'track_part','number of sink to track',iunit) - case default call write_inopt(apr_centre(1),'apr_centre(1)','centre of region x position',iunit) call write_inopt(apr_centre(2),'apr_centre(2)','centre of region y position',iunit) call write_inopt(apr_centre(3),'apr_centre(3)','centre of region z position',iunit) - end select + call write_inopt(apr_rad,'apr_rad','radius of innermost region',iunit) call write_inopt(apr_drad,'apr_drad','size of step to next region',iunit) end subroutine write_options_apr +!----------------------------------------------------------------------- +!+ +! Find the closest neighbour to a particle (needs replacing) +!+ +!----------------------------------------------------------------------- subroutine closest_neigh(i,next_door,rmin) use part, only:xyzh,npart integer, intent(in) :: i diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index 8997a9cb0..e0ea77a77 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -52,7 +52,7 @@ module setstar public :: shift_star,shift_stars public :: write_options_star,write_options_stars public :: read_options_star,read_options_stars - public :: set_star_interactive + public :: set_stars_interactive public :: ikepler,imesa,ibpwpoly,ipoly,iuniform,ifromfile,ievrard public :: need_polyk @@ -102,9 +102,15 @@ end subroutine set_defaults_star !+ !-------------------------------------------------------------------------- subroutine set_defaults_stars(stars) + use eos, only:use_var_comp,gmw,X_in,Z_in type(star_t), intent(out) :: stars(:) integer :: i + EOSopt = 1 + gmw = 0.5988 + X_in = 0.74 + Z_in = 0.02 + use_var_comp = .false. do i=1,size(stars) call set_defaults_star(stars(i)) enddo @@ -432,7 +438,6 @@ subroutine set_stars(id,master,nstars,star,xyzh,vxyzu,eos_vars,rad,& procedure(mask_prototype) :: mask integer :: i - print*,' HERE ieos=',ieos,EOSopt if (ieos==9) call init_eos_piecewise_preset(EOSopt) call init_eos(ieos,ierr) if (ierr /= 0) then @@ -579,15 +584,13 @@ end subroutine write_mass ! This routine should not do ANY prompting !+ !----------------------------------------------------------------------- -subroutine set_defaults_given_profile(iprofile,filename,need_iso,ieos,mstar,polyk) +subroutine set_defaults_given_profile(iprofile,filename,ieos,mstar,polyk) integer, intent(in) :: iprofile character(len=120), intent(out) :: filename - integer, intent(out) :: need_iso integer, intent(inout) :: ieos real, intent(inout) :: polyk character(len=20), intent(out) :: mstar - need_iso = 0 select case(iprofile) case(ifromfile) ! Read the density profile from file (e.g. for neutron star) @@ -605,11 +608,9 @@ subroutine set_defaults_given_profile(iprofile,filename,need_iso,ieos,mstar,poly ! piecewise polytrope ! Original Author: Madeline Marshall & Bernard Field ! Supervisors: James Wurster & Paul Lasky - ieos = 9 - Mstar = '1.35' - polyk = 144. - case(ievrard) - need_iso = -1 + ieos = 9 + Mstar = '1.35' + polyk = 144. end select end subroutine set_defaults_given_profile @@ -619,14 +620,11 @@ end subroutine set_defaults_given_profile ! interactive prompting for setting up a star !+ !----------------------------------------------------------------------- -subroutine set_star_interactive(id,master,star,need_iso,use_var_comp,ieos) +subroutine set_star_interactive(star,ieos) use prompting, only:prompt use setstar_utils, only:nprofile_opts,profile_opt,need_inputprofile,need_rstar use units, only:in_code_units type(star_t), intent(out) :: star - integer, intent(in) :: id,master - logical, intent(out) :: use_var_comp - integer, intent(out) :: need_iso integer, intent(inout) :: ieos integer :: i @@ -642,9 +640,9 @@ subroutine set_star_interactive(id,master,star,need_iso,use_var_comp,ieos) ! ! set default file output parameters ! - if (id==master) write(*,"('Setting up ',a)") trim(profile_opt(star%iprofile)) + write(*,"('Setting up ',a)") trim(profile_opt(star%iprofile)) call set_defaults_given_profile(star%iprofile,star%input_profile,& - need_iso,ieos,star%m,star%polyk) + ieos,star%m,star%polyk) ! resolution if (star%iprofile > 0) then @@ -664,8 +662,6 @@ subroutine set_star_interactive(id,master,star,need_iso,use_var_comp,ieos) select case (star%iprofile) case(imesa) - call prompt('Use variable composition?',use_var_comp) - print*,'Soften the core density profile and add a sink particle core?' print "(3(/,a))",'0: Do not soften profile', & '1: Use cubic softened density profile', & @@ -717,6 +713,44 @@ subroutine set_star_interactive(id,master,star,need_iso,use_var_comp,ieos) end subroutine set_star_interactive +!----------------------------------------------------------------------- +!+ +! as above but wrapper routine for multiple stars +!+ +!----------------------------------------------------------------------- +subroutine set_stars_interactive(star,ieos,relax,nstar) + use prompting, only:prompt + type(star_t), intent(out) :: star(:) + integer, intent(inout) :: ieos + logical, intent(out) :: relax + integer, intent(out), optional :: nstar + integer :: i,nstars + + call set_defaults_stars(star) + + ! optionally ask for number of stars, otherwise fix nstars to the input array size + if (present(nstar) .and. size(star) > 1) then + call prompt('how many stars to set up (0-'//achar(size(star)+48)//')',nstar,0,size(star)) + nstars = nstar + else + nstars = size(star) + endif + + do i=1,nstars + print "(/,'------------- STAR ',i0,'-------------')",i + call set_star_interactive(star(i),ieos) + enddo + + ! prompt for equation of state and relaxation options if any stars made of gas + if (nstars > 0) then + if (any(star(1:nstars)%iprofile > 0)) then + call set_star_eos_interactive(ieos,star) + call prompt('Relax stars automatically during setup?',relax) + endif + endif + +end subroutine set_stars_interactive + !----------------------------------------------------------------------- !+ ! write setupfile options needed for a star @@ -814,12 +848,11 @@ end subroutine write_options_star ! read setupfile options needed for a star !+ !----------------------------------------------------------------------- -subroutine read_options_star(star,need_iso,ieos,db,nerr,label) +subroutine read_options_star(star,ieos,db,nerr,label) use infile_utils, only:inopts,read_inopt use setstar_utils, only:need_inputprofile,need_rstar,nprofile_opts type(star_t), intent(out) :: star type(inopts), allocatable, intent(inout) :: db(:) - integer, intent(out) :: need_iso integer, intent(inout) :: ieos integer, intent(inout) :: nerr character(len=*), intent(in), optional :: label @@ -837,7 +870,7 @@ subroutine read_options_star(star,need_iso,ieos,db,nerr,label) call read_inopt(star%iprofile,'iprofile'//trim(c),db,errcount=nerr,min=0,max=nprofile_opts) call set_defaults_given_profile(star%iprofile,star%input_profile,& - need_iso,ieos,star%m,star%polyk) + ieos,star%m,star%polyk) if (need_inputprofile(star%iprofile)) then call read_inopt(star%input_profile,'input_profile'//trim(c),db,errcount=nerr) @@ -916,12 +949,13 @@ end subroutine read_options_star ! write_options routine that writes options for multiple stars !+ !----------------------------------------------------------------------- -subroutine write_options_stars(star,relax,ieos,iunit,nstar) +subroutine write_options_stars(star,relax,write_rho_to_file,ieos,iunit,nstar) use relaxstar, only:write_options_relax use infile_utils, only:write_inopt + use apr, only:use_apr,write_options_apr type(star_t), intent(in) :: star(:) integer, intent(in) :: ieos,iunit - logical, intent(in) :: relax + logical, intent(in) :: relax,write_rho_to_file integer, intent(in), optional :: nstar integer :: i,nstars @@ -950,9 +984,12 @@ subroutine write_options_stars(star,relax,ieos,iunit,nstar) write(iunit,"(/,a)") '# relaxation options' call write_inopt(relax,'relax','relax stars into equilibrium',iunit) call write_options_relax(iunit) + call write_inopt(write_rho_to_file,'write_rho_to_file','write density profile(s) to file',iunit) endif endif + if (use_apr) call write_options_apr(iunit) + end subroutine write_options_stars !----------------------------------------------------------------------- @@ -960,14 +997,14 @@ end subroutine write_options_stars ! read_options routine that reads options for multiple stars !+ !----------------------------------------------------------------------- -subroutine read_options_stars(star,need_iso,ieos,relax,db,nerr,nstar) +subroutine read_options_stars(star,ieos,relax,write_rho_to_file,db,nerr,nstar) use relaxstar, only:read_options_relax use infile_utils, only:inopts,read_inopt + use apr, only:use_apr,apr_max_in,ref_dir,apr_type,apr_rad,apr_drad type(star_t), intent(out) :: star(:) type(inopts), allocatable, intent(inout) :: db(:) - integer, intent(out) :: need_iso integer, intent(inout) :: ieos - logical, intent(out) :: relax + logical, intent(out) :: relax,write_rho_to_file integer, intent(inout) :: nerr integer, intent(out), optional :: nstar integer :: i,nstars @@ -987,17 +1024,27 @@ subroutine read_options_stars(star,need_iso,ieos,relax,db,nerr,nstar) ! read options for each star do i=1,nstars - call read_options_star(star(i),need_iso,ieos,db,nerr,label=achar(i+48)) + call read_options_star(star(i),ieos,db,nerr,label=achar(i+48)) enddo ! read relaxation options if any stars are made of gas if (nstars > 0) then if (any(star(1:nstars)%iprofile > 0)) then call read_inopt(relax,'relax',db,errcount=nerr) - call read_options_relax(db,nerr) + call read_options_relax(db,nerr) + ! option to write density profile to file + call read_inopt(write_rho_to_file,'write_rho_to_file',db,errcount=nerr) endif endif + if (use_apr) then + call read_inopt(apr_max_in,'apr_max',db,errcount=nerr) + call read_inopt(ref_dir,'ref_dir',db,errcount=nerr) + call read_inopt(apr_type,'apr_type',db,errcount=nerr) + call read_inopt(apr_rad,'apr_rad',db,errcount=nerr) + call read_inopt(apr_drad,'apr_drad',db,errcount=nerr) + endif + end subroutine read_options_stars !----------------------------------------------------------------------- @@ -1069,4 +1116,38 @@ subroutine read_options_stars_eos(star,ieos,db,nerr) end subroutine read_options_stars_eos +!------------------------------------------------------------------------ +!+ +! interactive prompt for equation of state options needed to setup stars +!+ +!------------------------------------------------------------------------ +subroutine set_star_eos_interactive(ieos,star) + use prompting, only:prompt + use eos, only:use_var_comp,X_in,Z_in,irecomb,gamma,gmw + integer, intent(inout) :: ieos + type(star_t), intent(in) :: star(:) + + ! equation of state + call prompt('Enter the desired EoS (1=isothermal,2=adiabatic,10=MESA,12=idealplusrad)',ieos) + if (any(star(:)%iprofile==imesa)) call prompt('Use variable composition?',use_var_comp) + + select case(ieos) + case(9) + write(*,'(a)') 'EOS options: 1=APR3,2=SLy,3=MS1,4=ENG (from Read et al 2009)' + call prompt('Enter equation of state type',EOSopt,1,4) + case(2,12) + call prompt('Enter gamma (adiabatic index)',gamma,1.,7.) + if ( (.not. use_var_comp) .and. any(need_mu(star(:)%isoftcore))) then + call prompt('Enter mean molecular weight',gmw,0.) + endif + case(10,20) + if (ieos==20) call prompt('Enter irecomb (0: H2+H+He, 1:H+He, 2:He)',irecomb,0) + if ( (.not. use_var_comp) .and. any(need_mu(star(:)%isoftcore))) then + call prompt('Enter hydrogen mass fraction (X)',X_in,0.,1.) + call prompt('Enter metals mass fraction (Z)',Z_in,0.,1.) + endif + end select + +end subroutine set_star_eos_interactive + end module setstar diff --git a/src/setup/setup_star.f90 b/src/setup/setup_star.f90 index 1a11292f3..21c8db2d8 100644 --- a/src/setup/setup_star.f90 +++ b/src/setup/setup_star.f90 @@ -38,15 +38,12 @@ module setup use timestep, only:tmax,dtmax use eos, only:ieos use externalforces, only:iext_densprofile - use extern_densprofile, only:nrhotab - use setstar, only:ibpwpoly,ievrard,imesa,star_t,need_polyk + use setstar, only:star_t use setunits, only:dist_unit,mass_unit implicit none ! ! Input parameters ! - integer :: EOSopt - integer :: need_iso real :: maxvxyzu logical :: iexist logical :: relax_star_in_setup,write_rho_to_file @@ -63,15 +60,12 @@ module setup !+ !----------------------------------------------------------------------- subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact,time,fileprefix) - use units, only:set_units,select_unit use kernel, only:hfact_default - use eos, only:init_eos,finish_eos,gmw,X_in,Z_in - use eos_piecewise, only:init_eos_piecewise_preset use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,eos_vars,rad - use mpiutils, only:reduceall_mpi + use eos, only:X_in,Z_in use mpidomain, only:i_belong use setup_params, only:rhozero,npart_total - use setstar, only:set_star + use setstar, only:set_stars,ibpwpoly,ievrard integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) @@ -92,23 +86,11 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, gamma = 5./3. hfact = hfact_default maxvxyzu = size(vxyzu(:,1)) - relax_star_in_setup = .false. - write_rho_to_file = .false. - ! ! set default options ! dist_unit = 'solarr' mass_unit = 'solarm' - EOSopt = 1 - gmw = 0.5988 - X_in = 0.74 - Z_in = 0.02 - use_var_comp = .false. - ! - ! defaults needed for error checking - ! - need_iso = 0 ! -1 = no; 0 = doesn't matter; 1 = yes ! ! determine if the .in file exists ! @@ -125,16 +107,16 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, setupfile = trim(fileprefix)//'.setup' inquire(file=setupfile,exist=setexists) if (setexists) then - call read_setupfile(setupfile,gamma,need_iso,ierr) + call read_setupfile(setupfile,ierr) if (ierr /= 0) then - if (id==master) call write_setupfile(setupfile,gamma,polyk) + if (id==master) call write_setupfile(setupfile) stop 'please rerun phantomsetup with revised .setup file' endif !--Prompt to get inputs and write to file elseif (id==master) then print "(a,/)",trim(setupfile)//' not found: using interactive setup' - call setup_interactive(gamma,iexist,id,master,ierr) - call write_setupfile(setupfile,gamma,polyk) + call setup_interactive(ieos) + call write_setupfile(setupfile) stop 'please check and edit .setup file and rerun phantomsetup' endif @@ -145,31 +127,17 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, iexternalforce = iext_densprofile write_rho_to_file = .true. endif - - if (maxvxyzu > 3 .and. need_iso == 1) call fatal('setup','require ISOTHERMAL=yes') - if (maxvxyzu < 4 .and. need_iso ==-1) call fatal('setup','require ISOTHERMAL=no') - ! - ! initialise the equation of state - ! - if (ieos==9) call init_eos_piecewise_preset(EOSopt) - call init_eos(ieos,ierr) - if (ierr /= 0) call fatal('setup','could not initialise equation of state') ! ! set up particles ! npartoftype(:) = 0 npart = 0 nptmass = 0 - vxyzu = 0.0 - call set_star(id,master,star(1),xyzh,vxyzu,eos_vars,rad,npart,npartoftype,& - massoftype,hfact,xyzmh_ptmass,vxyz_ptmass,nptmass,ieos,gamma,& - X_in,Z_in,relax_star_in_setup,use_var_comp,write_rho_to_file,& - rhozero,npart_total,i_belong,ierr) - ! - ! finish/deallocate equation of state tables - ! - call finish_eos(ieos,ierr) - + call set_stars(id,master,1,star,xyzh,vxyzu,eos_vars,rad,& + npart,npartoftype,massoftype,hfact,& + xyzmh_ptmass,vxyz_ptmass,nptmass,ieos,gamma,X_in,Z_in,& + relax_star_in_setup,use_var_comp,write_rho_to_file,& + rhozero,npart_total,i_belong,ierr) ! ! override some default settings in the .in file for some cases ! @@ -191,47 +159,16 @@ end subroutine setpart ! Ask questions of the user to determine which setup to use !+ !----------------------------------------------------------------------- -subroutine setup_interactive(gamma,iexist,id,master,ierr) - use prompting, only:prompt - use units, only:select_unit - use eos, only:X_in,Z_in,gmw - use eos_gasradrec, only:irecomb - use setstar, only:set_star_interactive +subroutine setup_interactive(ieos) + use setstar, only:set_stars_interactive use setunits, only:set_units_interactive - real, intent(out) :: gamma - logical, intent(in) :: iexist - integer, intent(in) :: id,master - integer, intent(out) :: ierr - - ierr = 0 + integer, intent(inout) :: ieos ! units call set_units_interactive(gr) ! star - !call set_star_interactive(id,master,star,need_iso,use_var_comp,ieos) - -! ! equation of state -! call prompt('Enter the desired EoS (1=isothermal,2=adiabatic,10=MESA,12=idealplusrad)',ieos) -! select case(ieos) -! case(9) -! write(*,'(a)') 'EOS options: 1=APR3,2=SLy,3=MS1,4=ENG (from Read et al 2009)' -! call prompt('Enter equation of state type',EOSopt,1,4) -! case(2) -! call prompt('Enter gamma (adiabatic index)',gamma,1.,7.) -! case(20) -! call prompt('Enter irecomb (0: H2+H+He, 1:H+He, 2:He)',irecomb,0) -! end select - -! if ((.not. use_var_comp) .and. (star%isoftcore<=0)) then -! if ( (ieos==12) .or. (ieos==2) ) call prompt('Enter mean molecular weight',gmw,0.) -! if ( (ieos==10) .or. (ieos==20) ) then -! call prompt('Enter hydrogen mass fraction (X)',X_in,0.,1.) -! call prompt('Enter metals mass fraction (Z)',Z_in,0.,1.) -! endif -! endif - -! call prompt('Relax star automatically during setup?',relax_star_in_setup) + call set_stars_interactive(star,ieos,relax_star_in_setup) end subroutine setup_interactive @@ -240,16 +177,10 @@ end subroutine setup_interactive ! Write setup parameters to input file !+ !----------------------------------------------------------------------- -subroutine write_setupfile(filename,gamma,polyk) - use infile_utils, only:write_inopt - use dim, only:tagline,use_apr - use relaxstar, only:write_options_relax - use eos, only:ieos - use eos_gasradrec, only:irecomb - use setstar, only:write_options_stars,need_polyk +subroutine write_setupfile(filename) + use dim, only:tagline + use setstar, only:write_options_stars use setunits, only:write_options_units - use apr, only:write_options_apr - real, intent(in) :: gamma,polyk character(len=*), intent(in) :: filename integer, parameter :: iunit = 20 @@ -259,43 +190,7 @@ subroutine write_setupfile(filename,gamma,polyk) write(iunit,"(a)") '# input file for Phantom star setup' call write_options_units(iunit,gr) - call write_options_stars(star,relax_star_in_setup,ieos,iunit) - - !write(iunit,"(/,a)") '# equation of state' - !call write_inopt(ieos,'ieos','1=isothermal,2=adiabatic,10=MESA,12=idealplusrad',iunit) - - !if (star%iprofile==imesa) then - ! call write_inopt(use_var_comp,'use_var_comp','Use variable composition (X, Z, mu)',iunit) - !endif - - !select case(ieos) - !case(15) ! Helmholtz - ! call write_inopt(star%initialtemp,'initialtemp','initial temperature of the star',iunit) - !case(9) - ! write(iunit,"(/,a)") '# Piecewise Polytrope default options' - ! call write_inopt(EOSopt,'EOSopt','EOS: 1=APR3,2=SLy,3=MS1,4=ENG (from Read et al 2009)',iunit) - !case(2) - ! call write_inopt(gamma,'gamma','Adiabatic index',iunit) - ! if ((star%isoftcore<=0) .and. (.not. use_var_comp)) call write_inopt(gmw,'mu','mean molecular weight',iunit) - !case(10,20) - ! if (ieos==20) call write_inopt(irecomb,'irecomb','Species to include in recombination (0: H2+H+He, 1:H+He, 2:He',iunit) - ! if ( (.not. use_var_comp) .and. (star%isoftcore <= 0) ) then - ! call write_inopt(X_in,'X','hydrogen mass fraction',iunit) - ! call write_inopt(Z_in,'Z','metallicity',iunit) - ! endif - !case(12) - ! call write_inopt(gamma,'gamma','Adiabatic index',iunit) - ! if ((star%isoftcore<=0) .and. (.not. use_var_comp)) call write_inopt(gmw,'mu','mean molecular weight',iunit) - !end select - - !write(iunit,"(/,a)") '# relaxation options' - !call write_inopt(relax_star_in_setup,'relax_star','relax star(s) automatically during setup',iunit) - !if (relax_star_in_setup) call write_options_relax(iunit) - - call write_inopt(write_rho_to_file,'write_rho_to_file','write density profile(s) to file',iunit) - - if (use_apr) call write_options_apr(iunit) - + call write_options_stars(star,relax_star_in_setup,write_rho_to_file,ieos,iunit) close(iunit) end subroutine write_setupfile @@ -304,21 +199,13 @@ end subroutine write_setupfile ! Read setup parameters from input file !+ !----------------------------------------------------------------------- -subroutine read_setupfile(filename,gamma,need_iso,ierr) - use infile_utils, only:open_db_from_file,inopts,close_db,read_inopt - use io, only:error - use units, only:select_unit - use relaxstar, only:read_options_relax - use eos, only:X_in,Z_in,gmw,ieos - use eos_gasradrec, only:irecomb +subroutine read_setupfile(filename,ierr) + use infile_utils, only:open_db_from_file,inopts,close_db use setstar, only:read_options_stars use setunits, only:read_options_and_set_units - use apr, only:apr_max_in,ref_dir,apr_type,apr_rad,apr_drad - use dim, only:use_apr character(len=*), intent(in) :: filename integer, parameter :: lu = 21 - integer, intent(out) :: need_iso,ierr - real, intent(out) :: gamma + integer, intent(out) :: ierr integer :: nerr type(inopts), allocatable :: db(:) @@ -331,50 +218,7 @@ subroutine read_setupfile(filename,gamma,need_iso,ierr) call read_options_and_set_units(db,nerr,gr) ! star options - call read_options_stars(star,need_iso,ieos,relax_star_in_setup,db,nerr) - - !! equation of state - !call read_inopt(ieos,'ieos',db,errcount=nerr) - !if (star%iprofile==imesa) call read_inopt(use_var_comp,'use_var_comp',db,errcount=nerr) - - !select case(ieos) - !case(15) ! Helmholtz - ! call read_inopt(star%initialtemp,'initialtemp',db,errcount=nerr) - !case(9) - ! call read_inopt(EOSopt,'EOSopt',db,errcount=nerr) - !case(2) - ! call read_inopt(gamma,'gamma',db,errcount=nerr) - ! if ( (.not. use_var_comp) .and. (star%isoftcore <= 0)) call read_inopt(gmw,'mu',db,errcount=nerr) - !case(10,20) - ! if (ieos==20) call read_inopt(irecomb,'irecomb',db,errcount=nerr) - ! ! if softening stellar core, composition is automatically determined at R/2 - ! if ( (.not. use_var_comp) .and. (star%isoftcore <= 0)) then - ! call read_inopt(X_in,'X',db,errcount=nerr) - ! call read_inopt(Z_in,'Z',db,errcount=nerr) - ! endif - !case(12) - ! if softening stellar core, mu is automatically determined at R/2 - ! call read_inopt(gamma,'gamma',db,errcount=nerr) - ! if ( (.not. use_var_comp) .and. (star%isoftcore <= 0)) call read_inopt(gmw,'mu',db,errcount=nerr) -! end select - - !if (need_polyk(star%iprofile)) call read_inopt(polyk,'polyk',db,errcount=nerr) - - ! relax star options - !call read_inopt(relax_star_in_setup,'relax_star',db,errcount=nerr) - !if (relax_star_in_setup) call read_options_relax(db,nerr)! - !if (nerr /= 0) ierr = ierr + 1 - - ! option to write density profile to file - call read_inopt(write_rho_to_file,'write_rho_to_file',db) - - if (use_apr) then - call read_inopt(apr_max_in,'apr_max',db,errcount=nerr) - call read_inopt(ref_dir,'ref_dir',db,errcount=nerr) - call read_inopt(apr_type,'apr_type',db,errcount=nerr) - call read_inopt(apr_rad,'apr_rad',db,errcount=nerr) - call read_inopt(apr_drad,'apr_drad',db,errcount=nerr) - endif + call read_options_stars(star,ieos,relax_star_in_setup,write_rho_to_file,db,nerr) if (nerr > 0) then print "(1x,a,i2,a)",'setup_star: ',nerr,' error(s) during read of setup file' diff --git a/src/tests/test_setstar.f90 b/src/tests/test_setstar.f90 index f9474ca05..a5202e827 100644 --- a/src/tests/test_setstar.f90 +++ b/src/tests/test_setstar.f90 @@ -156,9 +156,10 @@ subroutine test_polytrope(ntests,npass) ! do this test twice, to check the second star relaxes... do i=1,2 if (i==2) x0 = [3.,0.,0.] + call set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,& npart,npartoftype,massoftype,hfact,& - xyzmh_ptmass,vxyz_ptmass,nptmass,ieos,polyk,gamma,X_in,Z_in,& + xyzmh_ptmass,vxyz_ptmass,nptmass,ieos,gamma,X_in,Z_in,& relax=.true.,use_var_comp=.false.,write_rho_to_file=.false.,& rhozero=rhozero,npart_total=ntot,mask=i_belong,ierr=ierr,& write_files=.false.,density_error=rmserr,energy_error=ekin,x0=x0) From fc30fd35762b40fb0d9d52efd6295725a039101a Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 6 Dec 2024 16:51:58 +1100 Subject: [PATCH 112/134] (set_star) further issues with new set_star calls fixed in binary, grtde and star setups --- src/setup/set_star.f90 | 49 +++++++++++++++++++++++--------------- src/setup/setup_binary.f90 | 11 ++++----- src/setup/setup_grtde.f90 | 38 ++++++++++++++++------------- src/setup/setup_star.f90 | 11 ++++++++- 4 files changed, 67 insertions(+), 42 deletions(-) diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index e0ea77a77..b8bc2b47c 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -91,7 +91,7 @@ subroutine set_defaults_star(star) star%np = 1000 star%input_profile = 'P12_Phantom_Profile.data' star%outputfilename = 'mysoftenedstar.dat' - star%dens_profile = 'density-profile.tab' + star%dens_profile = 'density.profile' star%label = '' end subroutine set_defaults_star @@ -112,7 +112,7 @@ subroutine set_defaults_stars(stars) Z_in = 0.02 use_var_comp = .false. do i=1,size(stars) - call set_defaults_star(stars(i)) + if (len_trim(stars(i)%m)==0) call set_defaults_star(stars(i)) enddo end subroutine set_defaults_stars @@ -514,32 +514,40 @@ end subroutine shift_star !----------------------------------------------------------------------- !+ -! As above but shifts all stars to desired positions and velocities +! Shifts all stars to desired positions and velocities !+ !----------------------------------------------------------------------- -subroutine shift_stars(nstar,star,xyzmh_ptmass_in,vxyz_ptmass_in,& - xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,npart,npartoftype,nptmass,corotate) +subroutine shift_stars(nstar,star,x0,v0,& + xyzh,vxyzu,xyzmh_ptmass,vxyz_ptmass,& + npart,npartoftype,nptmass,corotate) + use part, only:ihacc,ihsoft integer, intent(in) :: nstar,npart type(star_t), intent(in) :: star(nstar) + real, intent(in) :: x0(3,nstar),v0(3,nstar) real, intent(inout) :: xyzh(:,:),vxyzu(:,:) - real, intent(in) :: xyzmh_ptmass_in(:,:),vxyz_ptmass_in(:,:) real, intent(inout) :: xyzmh_ptmass(:,:),vxyz_ptmass(:,:) integer, intent(inout) :: nptmass,npartoftype(:) logical, intent(in), optional :: corotate - integer :: i + integer :: i,ierr logical :: do_corotate + real :: rstar,mstar,rcore,mcore,hsoft,lcore,hacc do_corotate = .false. if (present(corotate)) do_corotate = corotate - do i=1,min(nstar,size(xyzmh_ptmass_in(1,:))) + do i=1,nstar if (star(i)%iprofile > 0) then - call shift_star(npart,npartoftype,xyzh,vxyzu,x0=xyzmh_ptmass_in(1:3,i),& - v0=vxyz_ptmass_in(1:3,i),itype=i,corotate=do_corotate) + call shift_star(npart,npartoftype,xyzh,vxyzu,x0=x0(1:3,i),& + v0=v0(1:3,i),itype=i,corotate=do_corotate) else + call get_star_properties_in_code_units(star(i),rstar,mstar,rcore,mcore,hsoft,lcore,hacc,ierr) + nptmass = nptmass + 1 - xyzmh_ptmass(:,nptmass) = xyzmh_ptmass_in(:,i) - vxyz_ptmass(:,nptmass) = vxyz_ptmass_in(:,i) + xyzmh_ptmass(1:3,nptmass) = x0(1:3,i) + xyzmh_ptmass(4,nptmass) = mstar + xyzmh_ptmass(ihsoft,nptmass) = hsoft + xyzmh_ptmass(ihacc, nptmass) = hacc + vxyz_ptmass(1:3,nptmass) = v0(1:3,i) endif enddo @@ -629,7 +637,7 @@ subroutine set_star_interactive(star,ieos) integer :: i ! set defaults - call set_defaults_star(star) + if (len_trim(star%m)==0) call set_defaults_star(star) ! Select sphere & set default values do i = 1, nprofile_opts @@ -654,9 +662,9 @@ subroutine set_star_interactive(star,ieos) if (need_inputprofile(star%iprofile)) then call prompt('Enter file name containing input profile',star%input_profile) else - call prompt('Enter the mass of the star (e.g. 1*msun)',star%m) + call prompt('Enter the mass of the star (e.g. 1*msun)',star%m,noblank=.true.) if (need_rstar(star%iprofile)) then - call prompt('Enter the radius of the star (e.g. 1*rsun)',star%r) + call prompt('Enter the radius of the star (e.g. 1*rsun)',star%r,noblank=.true.) endif endif @@ -756,11 +764,11 @@ end subroutine set_stars_interactive ! write setupfile options needed for a star !+ !----------------------------------------------------------------------- -subroutine write_options_star(star,iunit,ieos,label) +subroutine write_options_star(star,ieos,iunit,label) use infile_utils, only:write_inopt,get_optstring use setstar_utils, only:nprofile_opts,profile_opt,need_inputprofile,need_rstar,need_polyk type(star_t), intent(in) :: star - integer, intent(in) :: iunit,ieos + integer, intent(in) :: ieos,iunit character(len=*), intent(in), optional :: label character(len=120) :: string character(len=10) :: c @@ -861,12 +869,13 @@ subroutine read_options_star(star,ieos,db,nerr,label) real :: rstar,mstar,rcore,mcore,hsoft,lcore,hacc ! set defaults - call set_defaults_star(star) + if (len_trim(star%m)==0) call set_defaults_star(star) ! append optional label e.g. '1', '2' c = '' if (present(label)) c = trim(adjustl(label)) star%label = trim(c) + star%dens_profile = 'relax'//trim(c)//'.profile' call read_inopt(star%iprofile,'iprofile'//trim(c),db,errcount=nerr,min=0,max=nprofile_opts) call set_defaults_given_profile(star%iprofile,star%input_profile,& @@ -969,7 +978,7 @@ subroutine write_options_stars(star,relax,write_rho_to_file,ieos,iunit,nstar) ! write options for each star do i=1,nstars - call write_options_star(star(i),iunit,ieos,label=achar(i+48)) + call write_options_star(star(i),ieos,iunit,label=achar(i+48)) enddo ! write equation of state options if any stars made of gas @@ -1009,6 +1018,8 @@ subroutine read_options_stars(star,ieos,relax,write_rho_to_file,db,nerr,nstar) integer, intent(out), optional :: nstar integer :: i,nstars + call set_defaults_stars(star) + ! optionally ask for number of stars if (present(nstar)) then call read_inopt(nstar,'nstars',db,errcount=nerr,min=0,max=size(star)) diff --git a/src/setup/setup_binary.f90 b/src/setup/setup_binary.f90 index 1291b6805..5bebb3c3f 100644 --- a/src/setup/setup_binary.f90 +++ b/src/setup/setup_binary.f90 @@ -25,7 +25,7 @@ module setup implicit none public :: setpart - logical :: relax,corotate + logical :: relax,write_rho_to_file,corotate type(star_t) :: star(2) type(orbit_t) :: orbit @@ -142,7 +142,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,& ! !--place stars into orbit, or add real sink particles if iprofile=0 ! - call shift_stars(nstar,star,xyzmh_ptmass_in,vxyz_ptmass_in,xyzh,vxyzu,& + call shift_stars(nstar,star,xyzmh_ptmass_in(1:3,:),vxyz_ptmass_in(1:3,:),xyzh,vxyzu,& xyzmh_ptmass,vxyz_ptmass,npart,npartoftype,nptmass,corotate=add_spin) ! !--restore options @@ -188,7 +188,7 @@ subroutine write_setupfile(filename,ieos) write(iunit,"(a)") '# input file for binary setup routines' call write_options_units(iunit,gr) - call write_options_stars(star,relax,ieos,iunit) + call write_options_stars(star,relax,write_rho_to_file,ieos,iunit) call write_inopt(corotate,'corotate','set stars in corotation',iunit) call write_options_orbit(orbit,iunit) close(iunit) @@ -210,15 +210,14 @@ subroutine read_setupfile(filename,ieos,ierr) integer, intent(inout) :: ieos integer, intent(out) :: ierr integer, parameter :: iunit = 21 - integer :: nerr,need_iso + integer :: nerr type(inopts), allocatable :: db(:) nerr = 0 ierr = 0 call open_db_from_file(db,filename,iunit,ierr) call read_options_and_set_units(db,nerr,gr) - call read_options_stars(star,need_iso,ieos,relax,db,nerr) - if (need_iso==1) call fatal('setup_binary','incompatible setup for eos') + call read_options_stars(star,ieos,relax,write_rho_to_file,db,nerr) call read_inopt(corotate,'corotate',db,errcount=nerr) call read_options_orbit(orbit,db,nerr) call close_db(db) diff --git a/src/setup/setup_grtde.f90 b/src/setup/setup_grtde.f90 index 475989343..bb25f7e19 100644 --- a/src/setup/setup_grtde.f90 +++ b/src/setup/setup_grtde.f90 @@ -48,7 +48,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,ihacc,ihsoft,igas,& gravity,eos_vars,rad,gr use setbinary, only:set_binary - use setstar, only:set_star,shift_star + use setstar, only:set_star,shift_star,set_defaults_star use units, only:set_units,umass,udist use physcon, only:solarm,pi,solarr use io, only:master,fatal,warning @@ -63,6 +63,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use setup_params, only:rhozero,npart_total use systemutils, only:get_command_option use options, only:iexternalforce + use units, only:in_code_units integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) @@ -77,7 +78,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, logical :: iexist,write_profile,use_var_comp real :: rtidal,rp,semia,period,hacc1,hacc2 real :: vxyzstar(3),xyzstar(3) - real :: r0,vel,lorentz + real :: r0,vel,lorentz,mstar,rstar real :: vhat(3),x0,y0 ! !-- general parameters @@ -101,8 +102,9 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! mhole = 1.e6 ! (solar masses) call set_units(mass=mhole*solarm,c=1.d0,G=1.d0) !--Set central mass to M=1 in code units - star%mstar = 1.*solarm/umass - star%rstar = 1.*solarr/udist + call set_defaults_star(star) + star%m = '1.*msun' + star%r = '1.*solarr' np_default = 1e6 star%np = int(get_command_option('np',default=np_default)) ! can set default value with --np=1e5 flag (mainly for testsuite) star%iprofile = 2 @@ -120,7 +122,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, if (id==master) print "(/,65('-'),1(/,a),/,65('-'),/)",' Tidal disruption in GR' filename = trim(fileprefix)//'.setup' inquire(file=filename,exist=iexist) - if (iexist) call read_setupfile(filename,ieos,polyk,ierr) + if (iexist) call read_setupfile(filename,ieos,ierr) if (.not. iexist .or. ierr /= 0) then if (id==master) then call write_setupfile(filename) @@ -133,24 +135,28 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, !--set up and relax a star ! call set_star(id,master,star,xyzh,vxyzu,eos_vars,rad,npart,npartoftype,& - massoftype,hfact,xyzmh_ptmass,vxyz_ptmass,nptmass,ieos,polyk,gamma,& + massoftype,hfact,xyzmh_ptmass,vxyz_ptmass,nptmass,ieos,gamma,& X_in,Z_in,relax,use_var_comp,write_profile,& rhozero,npart_total,i_belong,ierr) if (ierr /= 0) call fatal('setup','errors in set_star') + rstar = in_code_units(star%r,ierr,unit_type='length') + if (ierr /= 0) call fatal('setup','could not convert rstar to code units') + mstar = in_code_units(star%m,ierr,unit_type='mass') + if (ierr /= 0) call fatal('setup','could not convert mstar to code units') ! !--place star into orbit ! - rtidal = star%rstar*(mass1/star%mstar)**(1./3.) + rtidal = rstar*(mass1/mstar)**(1./3.) rp = rtidal/beta accradius1_hard = 5.*mass1 accradius1 = accradius1_hard a = 0. theta = theta*pi/180. - print*, 'mstar', star%mstar - print*, 'rstar', star%rstar + print*, 'mstar', mstar + print*, 'rstar', rstar print*, 'umass', umass print*, 'udist', udist print*, 'mass1', mass1 @@ -168,11 +174,11 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, semia = rp/(1.-ecc) period = 2.*pi*sqrt(semia**3/mass1) print*, 'period', period - hacc1 = star%rstar/1.e8 ! Something small so that set_binary doesnt warn about Roche lobe + hacc1 = rstar/1.e8 ! Something small so that set_binary doesnt warn about Roche lobe hacc2 = hacc1 ! apocentre = rp*(1.+ecc)/(1.-ecc) ! trueanom = acos((rp*(1.+ecc)/r0 - 1.)/ecc)*180./pi - call set_binary(mass1,star%mstar,semia,ecc,hacc1,hacc2,xyzmh_ptmass,vxyz_ptmass,nptmass,ierr,& + call set_binary(mass1,mstar,semia,ecc,hacc1,hacc2,xyzmh_ptmass,vxyz_ptmass,nptmass,ierr,& posang_ascnode=0.,arg_peri=90.,incl=0.,f=-180.) vxyzstar = vxyz_ptmass(1:3,2) xyzstar = xyzmh_ptmass(1:3,2) @@ -244,13 +250,14 @@ subroutine write_setupfile(filename) use infile_utils, only:write_inopt use setstar, only:write_options_star use relaxstar, only:write_options_relax + use eos, only:ieos character(len=*), intent(in) :: filename integer :: iunit print "(a)",' writing setup options file '//trim(filename) open(newunit=iunit,file=filename,status='replace',form='formatted') write(iunit,"(a)") '# input file for tidal disruption setup' - call write_options_star(star,iunit) + call write_options_star(star,ieos,iunit) call write_inopt(relax,'relax','relax star into hydrostatic equilibrium',iunit) if (relax) call write_options_relax(iunit) @@ -265,7 +272,7 @@ subroutine write_setupfile(filename) end subroutine write_setupfile -subroutine read_setupfile(filename,ieos,polyk,ierr) +subroutine read_setupfile(filename,ieos,ierr) use infile_utils, only:open_db_from_file,inopts,read_inopt,close_db use io, only:error use setstar, only:read_options_star @@ -274,10 +281,9 @@ subroutine read_setupfile(filename,ieos,polyk,ierr) use units, only:set_units character(len=*), intent(in) :: filename integer, intent(inout) :: ieos - real, intent(inout) :: polyk integer, intent(out) :: ierr integer, parameter :: iunit = 21 - integer :: nerr,need_iso + integer :: nerr type(inopts), allocatable :: db(:) print "(a)",'reading setup options from '//trim(filename) @@ -292,7 +298,7 @@ subroutine read_setupfile(filename,ieos,polyk,ierr) ! !--read star options and convert to code units ! - call read_options_star(star,need_iso,ieos,polyk,db,nerr) + call read_options_star(star,ieos,db,nerr) call read_inopt(relax,'relax',db,errcount=nerr) if (relax) call read_options_relax(db,nerr) diff --git a/src/setup/setup_star.f90 b/src/setup/setup_star.f90 index 21c8db2d8..563c2be8f 100644 --- a/src/setup/setup_star.f90 +++ b/src/setup/setup_star.f90 @@ -65,7 +65,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use eos, only:X_in,Z_in use mpidomain, only:i_belong use setup_params, only:rhozero,npart_total - use setstar, only:set_stars,ibpwpoly,ievrard + use setstar, only:set_stars,shift_stars,ibpwpoly,ievrard integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) @@ -78,6 +78,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, integer :: ierr logical :: setexists character(len=120) :: setupfile,inname + real :: x0(3,1),v0(3,1) ! ! Initialise parameters, including those that will not be included in *.setup ! @@ -139,6 +140,14 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, relax_star_in_setup,use_var_comp,write_rho_to_file,& rhozero,npart_total,i_belong,ierr) ! + ! put the star at the origin with zero velocity, + ! or replace with sink particle + ! + x0 = 0. + v0 = 0. + call shift_stars(1,star,x0,v0,xyzh,vxyzu,& + xyzmh_ptmass,vxyz_ptmass,npart,npartoftype,nptmass) + ! ! override some default settings in the .in file for some cases ! select case(star(1)%iprofile) From d92de15efff25d04c0dcf9c0af037b718b14cd36 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 6 Dec 2024 18:00:22 +1100 Subject: [PATCH 113/134] (set_star) bug fix with default values for mstar and rstar; now give defaults in msun and rsun; also fix issues with adding stars to grdisc --- src/setup/set_star.f90 | 22 +++----- src/setup/setup_grdisc.F90 | 103 ++++++++++++++++++++----------------- src/setup/setup_grtde.f90 | 2 +- src/setup/setup_star.f90 | 1 + 4 files changed, 63 insertions(+), 65 deletions(-) diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index b8bc2b47c..2b601342d 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -75,8 +75,8 @@ subroutine set_defaults_star(star) type(star_t), intent(out) :: star star%iprofile = 2 - star%r = '1.0' - star%m = '1.0' + star%r = '1.0*rsun' + star%m = '1.0*msun' star%ui_coef = 0.05 star%polyk = 0. star%initialtemp = 1.0e7 @@ -112,7 +112,7 @@ subroutine set_defaults_stars(stars) Z_in = 0.02 use_var_comp = .false. do i=1,size(stars) - if (len_trim(stars(i)%m)==0) call set_defaults_star(stars(i)) + call set_defaults_star(stars(i)) enddo end subroutine set_defaults_stars @@ -636,9 +636,6 @@ subroutine set_star_interactive(star,ieos) integer, intent(inout) :: ieos integer :: i - ! set defaults - if (len_trim(star%m)==0) call set_defaults_star(star) - ! Select sphere & set default values do i = 1, nprofile_opts write(*,"(i2,')',1x,a)") i, profile_opt(i) @@ -734,8 +731,6 @@ subroutine set_stars_interactive(star,ieos,relax,nstar) integer, intent(out), optional :: nstar integer :: i,nstars - call set_defaults_stars(star) - ! optionally ask for number of stars, otherwise fix nstars to the input array size if (present(nstar) .and. size(star) > 1) then call prompt('how many stars to set up (0-'//achar(size(star)+48)//')',nstar,0,size(star)) @@ -859,7 +854,7 @@ end subroutine write_options_star subroutine read_options_star(star,ieos,db,nerr,label) use infile_utils, only:inopts,read_inopt use setstar_utils, only:need_inputprofile,need_rstar,nprofile_opts - type(star_t), intent(out) :: star + type(star_t), intent(inout) :: star type(inopts), allocatable, intent(inout) :: db(:) integer, intent(inout) :: ieos integer, intent(inout) :: nerr @@ -868,9 +863,6 @@ subroutine read_options_star(star,ieos,db,nerr,label) integer :: ierr real :: rstar,mstar,rcore,mcore,hsoft,lcore,hacc - ! set defaults - if (len_trim(star%m)==0) call set_defaults_star(star) - ! append optional label e.g. '1', '2' c = '' if (present(label)) c = trim(adjustl(label)) @@ -949,7 +941,7 @@ subroutine read_options_star(star,ieos,db,nerr,label) endif ! perform a unit conversion, just to check that there are no errors parsing the .setup file - call get_star_properties_in_code_units(star,rstar,mstar,rcore,mcore,hsoft,lcore,hacc,nerr) + if (nerr==0) call get_star_properties_in_code_units(star,rstar,mstar,rcore,mcore,hsoft,lcore,hacc,nerr) end subroutine read_options_star @@ -1010,7 +1002,7 @@ subroutine read_options_stars(star,ieos,relax,write_rho_to_file,db,nerr,nstar) use relaxstar, only:read_options_relax use infile_utils, only:inopts,read_inopt use apr, only:use_apr,apr_max_in,ref_dir,apr_type,apr_rad,apr_drad - type(star_t), intent(out) :: star(:) + type(star_t), intent(inout) :: star(:) ! inout because can set default options manually in calling routine type(inopts), allocatable, intent(inout) :: db(:) integer, intent(inout) :: ieos logical, intent(out) :: relax,write_rho_to_file @@ -1018,8 +1010,6 @@ subroutine read_options_stars(star,ieos,relax,write_rho_to_file,db,nerr,nstar) integer, intent(out), optional :: nstar integer :: i,nstars - call set_defaults_stars(star) - ! optionally ask for number of stars if (present(nstar)) then call read_inopt(nstar,'nstars',db,errcount=nerr,min=0,max=size(star)) diff --git a/src/setup/setup_grdisc.F90 b/src/setup/setup_grdisc.F90 index 73d794714..00ef2c139 100644 --- a/src/setup/setup_grdisc.F90 +++ b/src/setup/setup_grdisc.F90 @@ -41,7 +41,7 @@ module setup real, private :: mhole,mdisc,r_in,r_out,r_ref,spin,honr,theta,p_index,q_index,accrad,gamma_ad integer, private :: np,nstars - logical, private :: ismooth,relax + logical, private :: ismooth,relax,write_rho_to_file integer, parameter :: max_stars = 10 type(star_t), private :: star(max_stars) type(orbit_t),private :: orbit(max_stars) @@ -61,7 +61,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use io, only:master use externalforces, only:accradius1,accradius1_hard use options, only:iexternalforce,alphau,iexternalforce,ipdv_heating,ishock_heating - use units, only:set_units,umass + use units, only:set_units,umass,in_code_units use physcon, only:solarm,pi #ifdef GR use metric, only:a @@ -73,7 +73,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use timestep, only:tmax,dtmax use eos, only:ieos,use_var_comp,X_in,Z_in use kernel, only:hfact_default - use setstar, only:shift_star,set_stars + use setstar, only:shift_star,set_stars,set_defaults_stars use setorbit, only:set_defaults_orbit,set_orbit use setunits, only:mass_unit use mpidomain, only:i_belong @@ -91,20 +91,15 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, integer :: ierr,nptmass_in,i integer(kind=8) :: npart_total logical :: iexist,write_profile - real :: cs2 + real :: cs2,mstar,rstar real :: xyzmh_ptmass_in(nsinkproperties,2),vxyz_ptmass_in(3,2) time = 0. alphau = 0.0 npartoftype(:) = 0 nptmass = 0 - iexternalforce = 1 hfact = hfact_default -#ifndef GR - iexternalforce = iext_einsteinprec -#endif - tmax = 2.e4 dtmax = 100. @@ -135,6 +130,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! stars nstars = 0 + call set_defaults_stars(star) do i=1,size(orbit) call set_defaults_orbit(orbit(i)) enddo @@ -146,16 +142,15 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, if (id==master) print "(/,65('-'),(/,1x,a),/,65('-'),/)",'General relativistic disc setup' filename = trim(fileprefix)//'.setup' inquire(file=filename,exist=iexist) - if (iexist) call read_setupfile(filename,ierr) + if (iexist) call read_setupfile(filename,ieos,ierr) if (.not. iexist .or. ierr /= 0) then if (id==master) then - call write_setupfile(filename) + call write_setupfile(filename,ieos) print*,' Edit '//trim(filename)//' and rerun phantomsetup' endif stop endif accradius1 = accrad - npart = np !-- Set gamma from the option read from .setup file gamma = gamma_ad @@ -167,14 +162,50 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, call set_units(G=1.,c=1.,mass=mhole) ! Set central mass to M=1 in code units mdisc = mdisc*solarm/umass accradius1_hard = accradius1 + massoftype(igas) = mdisc/np ! set particle mass from the disc mass + ! + ! add stars on desired orbits around the black hole, these could be + ! either sink particles or balls of gas + ! + if (nstars > 0) then + write_profile = .false. + iexternalforce = 0 + call set_stars(id,master,nstars,star,xyzh,vxyzu,eos_vars,rad,npart,npartoftype,& + massoftype,hfact,xyzmh_ptmass,vxyz_ptmass,nptmass,ieos,gamma,& + X_in,Z_in,relax,use_var_comp,write_profile,& + rhozero,npart_total,i_belong,ierr) + do i=1,nstars + nptmass_in = 0 + ! convert stellar mass and radius to code units + mstar = in_code_units(star(i)%m,ierr) + rstar = in_code_units(star(i)%r,ierr) + call set_orbit(orbit(i),mhole/umass,mstar,r_in,rstar, & + xyzmh_ptmass_in,vxyz_ptmass_in,nptmass_in,(id==master),ierr) + + ! shift the star to the position of the second body + if (star(i)%iprofile > 0) then + call shift_star(npart,npartoftype,xyzh,vxyzu,& + x0=xyzmh_ptmass_in(:,2),v0=vxyz_ptmass_in(:,2),itype=i) + else + nptmass = nptmass + 1 + xyzmh_ptmass(:,nptmass) = xyzmh_ptmass_in(:,2) + vxyz_ptmass(:,nptmass) = vxyz_ptmass_in(:,2) + endif + enddo +endif + +#ifndef GR + iexternalforce = iext_einsteinprec +#endif ! ! Convert to radians ! theta = theta/180. * pi call set_disc(id,master,& - npart = npart, & + npart = np, & + npart_start = npart+1, & rmin = r_in, & rmax = r_out, & rref = r_ref, & @@ -194,6 +225,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, bh_spin = spin, & prefix = fileprefix) + npart = npart + np + #ifdef GR a = spin ! Overwrite thermal energies to be correct for GR @@ -210,33 +243,6 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, npartoftype(1) = npart - ! - ! add stars on desired orbits around the black hole, these could be - ! either sink particles or balls of gas - ! - if (nstars > 0) then - write_profile = .false. - call set_stars(id,master,nstars,star,xyzh,vxyzu,eos_vars,rad,npart,npartoftype,& - massoftype,hfact,xyzmh_ptmass,vxyz_ptmass,nptmass,ieos,polyk,gamma,& - X_in,Z_in,relax,use_var_comp,write_profile,& - rhozero,npart_total,i_belong,ierr) - do i=1,nstars - nptmass_in = 0 - call set_orbit(orbit(i),mhole/umass,star(i)%mstar,r_in,star(i)%rstar, & - xyzmh_ptmass_in,vxyz_ptmass_in,nptmass_in,(id==master),ierr) - - ! shift the star to the position of the second body - if (star(i)%iprofile > 0) then - call shift_star(npart,npartoftype,xyzh,vxyzu,& - x0=xyzmh_ptmass_in(:,2),v0=vxyz_ptmass_in(:,2),itype=i) - else - nptmass = nptmass + 1 - xyzmh_ptmass(:,nptmass) = xyzmh_ptmass_in(:,2) - vxyz_ptmass(:,nptmass) = vxyz_ptmass_in(:,2) - endif - enddo - endif - ipdv_heating = 0 ishock_heating = 0 if (id==master) print "(/,a,/)",' ** SETTING ipdv_heating=0 and ishock_heating=0 for grdisc setup **' @@ -247,12 +253,13 @@ end subroutine setpart ! !---Read/write setup file-------------------------------------------------- ! -subroutine write_setupfile(filename) +subroutine write_setupfile(filename,ieos) use infile_utils, only:write_inopt use setstar, only:write_options_stars use setorbit, only:write_options_orbit use setunits, only:write_options_units character(len=*), intent(in) :: filename + integer, intent(in) :: ieos integer, parameter :: iunit = 20 integer :: i @@ -278,7 +285,7 @@ subroutine write_setupfile(filename) call write_inopt(np ,'np' ,'number of particles in disc' , iunit) write(iunit,"(/,a)") '# stars' - call write_options_stars(star,relax,iunit,nstar=nstars) + call write_options_stars(star,relax,write_rho_to_file,ieos,iunit,nstar=nstars) do i=1,nstars call write_options_orbit(orbit(i),iunit,label=achar(i+48)) enddo @@ -286,17 +293,17 @@ subroutine write_setupfile(filename) end subroutine write_setupfile -subroutine read_setupfile(filename,ierr) +subroutine read_setupfile(filename,ieos,ierr) use infile_utils, only:open_db_from_file,inopts,read_inopt,close_db use io, only:error use setstar, only:read_options_stars use setorbit, only:read_options_orbit - use eos, only:ieos,polyk use setunits, only:read_options_and_set_units - character(len=*), intent(in) :: filename - integer, intent(out) :: ierr + character(len=*), intent(in) :: filename + integer, intent(inout) :: ieos + integer, intent(out) :: ierr integer, parameter :: iunit = 21 - integer :: nerr,need_iso,i + integer :: nerr,i type(inopts), allocatable :: db(:) print "(a)",'reading setup options from '//trim(filename) @@ -319,7 +326,7 @@ subroutine read_setupfile(filename,ierr) call read_inopt(gamma_ad,'gamma' ,db,min=1.,errcount=nerr) call read_inopt(accrad ,'accrad' ,db,min=0.,errcount=nerr) call read_inopt(np ,'np ' ,db,min=0 ,errcount=nerr) - call read_options_stars(star,need_iso,ieos,polyk,relax,db,nerr,nstars) + call read_options_stars(star,ieos,relax,write_rho_to_file,db,nerr,nstars) do i=1,nstars call read_options_orbit(orbit(i),db,nerr,label=achar(i+48)) enddo diff --git a/src/setup/setup_grtde.f90 b/src/setup/setup_grtde.f90 index bb25f7e19..c0d251cb1 100644 --- a/src/setup/setup_grtde.f90 +++ b/src/setup/setup_grtde.f90 @@ -48,7 +48,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,ihacc,ihsoft,igas,& gravity,eos_vars,rad,gr use setbinary, only:set_binary - use setstar, only:set_star,shift_star,set_defaults_star + use setstar, only:set_star,shift_star,set_defaults_stars use units, only:set_units,umass,udist use physcon, only:solarm,pi,solarr use io, only:master,fatal,warning diff --git a/src/setup/setup_star.f90 b/src/setup/setup_star.f90 index 563c2be8f..ce9236b90 100644 --- a/src/setup/setup_star.f90 +++ b/src/setup/setup_star.f90 @@ -92,6 +92,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! dist_unit = 'solarr' mass_unit = 'solarm' + call set_defaults_stars(star) ! ! determine if the .in file exists ! From 85a3d9018533c84ca6a30abeead6ae84f6c9e6af Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 6 Dec 2024 20:44:13 +1100 Subject: [PATCH 114/134] (setstar) build and test failures fixed --- src/setup/setup_star.f90 | 2 +- src/tests/test_setstar.f90 | 8 +++++--- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/setup/setup_star.f90 b/src/setup/setup_star.f90 index ce9236b90..288b8b119 100644 --- a/src/setup/setup_star.f90 +++ b/src/setup/setup_star.f90 @@ -65,7 +65,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use eos, only:X_in,Z_in use mpidomain, only:i_belong use setup_params, only:rhozero,npart_total - use setstar, only:set_stars,shift_stars,ibpwpoly,ievrard + use setstar, only:set_defaults_stars,set_stars,shift_stars,ibpwpoly,ievrard integer, intent(in) :: id integer, intent(inout) :: npart integer, intent(out) :: npartoftype(:) diff --git a/src/tests/test_setstar.f90 b/src/tests/test_setstar.f90 index a5202e827..43f6b3468 100644 --- a/src/tests/test_setstar.f90 +++ b/src/tests/test_setstar.f90 @@ -131,13 +131,13 @@ subroutine test_polytrope(ntests,npass) use mpidomain, only:i_belong use options, only:ieos use physcon, only:solarr,solarm,pi - use eos, only:gamma,X_in,Z_in + use eos, only:gamma,X_in,Z_in,polyk use setstar, only:star_t,set_star,set_defaults_star,ipoly use units, only:set_units use checksetup, only:check_setup integer, intent(inout) :: ntests,npass type(star_t) :: star - real :: polyk,rhozero,rmserr,ekin,x0(3) + real :: rhozero,rmserr,ekin,x0(3) integer(kind=8) :: ntot integer :: ierr,nfail(1),i,nerror,nwarn @@ -148,7 +148,6 @@ subroutine test_polytrope(ntests,npass) call set_units(dist=solarr,mass=solarm,G=1.d0) ieos = 2 gamma = 5./3. - polyk = 1. call set_defaults_star(star) star%iprofile = ipoly ! a polytrope star%np = 1000 @@ -174,6 +173,9 @@ subroutine test_polytrope(ntests,npass) call checkval(rhozero,1./(4./3.*pi),1e-6,nfail(1),'mean density') call update_test_scores(ntests,nfail,npass) + call checkval(star%polyk,0.424304,1e-6,nfail(1),'polyk value for M=1,R=1') + call update_test_scores(ntests,nfail,npass) + call checkval(polyk,0.424304,1e-6,nfail(1),'polyk value for M=1,R=1') call update_test_scores(ntests,nfail,npass) From 4ceb2a5f5bb933d002b742efac802cd9b21a16eb Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Fri, 6 Dec 2024 20:58:47 +1100 Subject: [PATCH 115/134] (setstar) build and test failures fixed --- src/setup/setup_grtde.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/setup/setup_grtde.f90 b/src/setup/setup_grtde.f90 index c0d251cb1..bb25f7e19 100644 --- a/src/setup/setup_grtde.f90 +++ b/src/setup/setup_grtde.f90 @@ -48,7 +48,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, use part, only:nptmass,xyzmh_ptmass,vxyz_ptmass,ihacc,ihsoft,igas,& gravity,eos_vars,rad,gr use setbinary, only:set_binary - use setstar, only:set_star,shift_star,set_defaults_stars + use setstar, only:set_star,shift_star,set_defaults_star use units, only:set_units,umass,udist use physcon, only:solarm,pi,solarr use io, only:master,fatal,warning From 51f4661c5dbbb6927431cffe6cb751237c098813 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 9 Dec 2024 09:47:38 +1100 Subject: [PATCH 116/134] (wd) test failures fixed; also fixed issues with iprofile=0 in star setup --- src/main/utils_infiles.f90 | 49 ++++++++++++-- src/setup/set_star.f90 | 127 ++++++++++++++++++----------------- src/setup/set_star_utils.f90 | 6 +- 3 files changed, 115 insertions(+), 67 deletions(-) diff --git a/src/main/utils_infiles.f90 b/src/main/utils_infiles.f90 index 8b788ff80..4134a8114 100644 --- a/src/main/utils_infiles.f90 +++ b/src/main/utils_infiles.f90 @@ -21,6 +21,7 @@ module infile_utils public :: write_inopt, read_inopt public :: read_next_inopt, get_inopt public :: write_infile_series, check_infile, contains_loop, get_optstring + public :: int_to_string ! ! generic interface write_inopt to write an input option of any type ! @@ -1259,13 +1260,14 @@ end subroutine write_infile_lines ! Creates a string out of a list of options ! !--------------------------------------------------------------------------- -subroutine get_optstring(nopts,optstring,string,maxlen) +subroutine get_optstring(nopts,optstring,string,maxlen,from_zero) integer, intent(in) :: nopts character(len=*), intent(in) :: optstring(nopts) character(len=*), intent(out) :: string integer, intent(in), optional :: maxlen + logical, intent(in), optional :: from_zero character(len=len(string)) :: temp - integer :: i,maxl,ierr + integer :: i,maxl,ierr,ioffset if (present(maxlen)) then maxl = max(maxlen,1) @@ -1274,15 +1276,54 @@ subroutine get_optstring(nopts,optstring,string,maxlen) endif string = '' + !--allow for enumeration that starts from 0 instead of 1 + ioffset = 0 + if (present(from_zero)) then + if (from_zero) ioffset = 1 + endif + do i=1,nopts temp = adjustl(optstring(i)) if (i==nopts) then - write(string(len_trim(string)+1:),"(i0,'=',a)",iostat=ierr) i,trim(temp(1:maxl)) + write(string(len_trim(string)+1:),"(i0,'=',a)",iostat=ierr) i-ioffset,trim(temp(1:maxl)) else - write(string(len_trim(string)+1:),"(i0,'=',a,',')",iostat=ierr) i,trim(temp(1:maxl)) + write(string(len_trim(string)+1:),"(i0,'=',a,',')",iostat=ierr) i-ioffset,trim(temp(1:maxl)) endif enddo end subroutine get_optstring +!--------------------------------------------------------------------------- +! +! convert an integer to a string without using write statements +! so the function itself can be used in a print or write statement +! +!--------------------------------------------------------------------------- +function int_to_string(num) result(str) + integer, intent(in) :: num + character(len=20) :: str + integer :: i, n + character(len=1) :: digit + + n = abs(num) ! Get the absolute value of the number + str = '' ! Initialize the string + + ! Convert integer to string + do while (n > 0) + i = mod(n, 10) ! Get the last digit + digit = char(i + ichar('0')) ! Convert digit to character + str = trim(adjustl(digit)) // str ! Prepend digit to string + n = n / 10 ! Remove the last digit + enddo + + if (num < 0) then + str = '-' // trim(str) ! Add negative sign if necessary + endif + + if (num == 0) then + str = '0' ! Handle the case for zero + endif + +end function int_to_string + end module infile_utils diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index 2b601342d..a514bb1c1 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -592,12 +592,11 @@ end subroutine write_mass ! This routine should not do ANY prompting !+ !----------------------------------------------------------------------- -subroutine set_defaults_given_profile(iprofile,filename,ieos,mstar,polyk) +subroutine set_defaults_given_profile(iprofile,filename,mstar,polyk) integer, intent(in) :: iprofile character(len=120), intent(out) :: filename - integer, intent(inout) :: ieos real, intent(inout) :: polyk - character(len=20), intent(out) :: mstar + character(len=*), intent(inout) :: mstar select case(iprofile) case(ifromfile) @@ -616,8 +615,7 @@ subroutine set_defaults_given_profile(iprofile,filename,ieos,mstar,polyk) ! piecewise polytrope ! Original Author: Madeline Marshall & Bernard Field ! Supervisors: James Wurster & Paul Lasky - ieos = 9 - Mstar = '1.35' + Mstar = '1.35*msun' polyk = 144. end select @@ -628,26 +626,24 @@ end subroutine set_defaults_given_profile ! interactive prompting for setting up a star !+ !----------------------------------------------------------------------- -subroutine set_star_interactive(star,ieos) +subroutine set_star_interactive(star) use prompting, only:prompt use setstar_utils, only:nprofile_opts,profile_opt,need_inputprofile,need_rstar use units, only:in_code_units - type(star_t), intent(out) :: star - integer, intent(inout) :: ieos + type(star_t), intent(inout) :: star integer :: i ! Select sphere & set default values - do i = 1, nprofile_opts + do i = 0, nprofile_opts write(*,"(i2,')',1x,a)") i, profile_opt(i) enddo - call prompt('Enter which density profile to use',star%iprofile,1,nprofile_opts) + call prompt('Enter which density profile to use',star%iprofile,0,nprofile_opts) ! ! set default file output parameters ! write(*,"('Setting up ',a)") trim(profile_opt(star%iprofile)) - call set_defaults_given_profile(star%iprofile,star%input_profile,& - ieos,star%m,star%polyk) + call set_defaults_given_profile(star%iprofile,star%input_profile,star%m,star%polyk) ! resolution if (star%iprofile > 0) then @@ -724,8 +720,9 @@ end subroutine set_star_interactive !+ !----------------------------------------------------------------------- subroutine set_stars_interactive(star,ieos,relax,nstar) - use prompting, only:prompt - type(star_t), intent(out) :: star(:) + use prompting, only:prompt + use infile_utils, only:int_to_string + type(star_t), intent(inout) :: star(:) integer, intent(inout) :: ieos logical, intent(out) :: relax integer, intent(out), optional :: nstar @@ -733,7 +730,7 @@ subroutine set_stars_interactive(star,ieos,relax,nstar) ! optionally ask for number of stars, otherwise fix nstars to the input array size if (present(nstar) .and. size(star) > 1) then - call prompt('how many stars to set up (0-'//achar(size(star)+48)//')',nstar,0,size(star)) + call prompt('how many stars to set up (0-'//int_to_string(size(star))//')',nstar,0,size(star)) nstars = nstar else nstars = size(star) @@ -741,12 +738,13 @@ subroutine set_stars_interactive(star,ieos,relax,nstar) do i=1,nstars print "(/,'------------- STAR ',i0,'-------------')",i - call set_star_interactive(star(i),ieos) + call set_star_interactive(star(i)) enddo ! prompt for equation of state and relaxation options if any stars made of gas if (nstars > 0) then if (any(star(1:nstars)%iprofile > 0)) then + if (any(star(1:nstars)%iprofile==ibpwpoly)) ieos = 9 ! set default eos for piecewise polytropes call set_star_eos_interactive(ieos,star) call prompt('Relax stars automatically during setup?',relax) endif @@ -759,11 +757,11 @@ end subroutine set_stars_interactive ! write setupfile options needed for a star !+ !----------------------------------------------------------------------- -subroutine write_options_star(star,ieos,iunit,label) +subroutine write_options_star(star,iunit,label) use infile_utils, only:write_inopt,get_optstring use setstar_utils, only:nprofile_opts,profile_opt,need_inputprofile,need_rstar,need_polyk type(star_t), intent(in) :: star - integer, intent(in) :: ieos,iunit + integer, intent(in) :: iunit character(len=*), intent(in), optional :: label character(len=120) :: string character(len=10) :: c @@ -773,8 +771,8 @@ subroutine write_options_star(star,ieos,iunit,label) if (present(label)) c = trim(adjustl(label)) write(iunit,"(/,a)") '# options for star '//trim(c) - call get_optstring(nprofile_opts,profile_opt,string,4) - call write_inopt(star%iprofile,'iprofile'//trim(c),'0=Sink,'//trim(string(1:40)),iunit) + call get_optstring(nprofile_opts+1,profile_opt,string,4,from_zero=.true.) + call write_inopt(star%iprofile,'iprofile'//trim(c),trim(string(1:48)),iunit) if (star%isoftcore <= 0) then if (need_inputprofile(star%iprofile)) then @@ -834,12 +832,6 @@ subroutine write_options_star(star,ieos,iunit,label) if (need_polyk(star%iprofile)) call write_inopt(star%polyk,'polyk'//trim(c),'polytropic constant (cs^2 if isothermal)',iunit) - ! options for setting initial thermal energy (e.g. if degenerate matter eos) - select case(ieos) - case(15) - call write_inopt(star%initialtemp,'initialtemp'//trim(c),'initial temperature of star (e.g. if degenerate matter eos)',iunit) - end select - if (star%iprofile > 0 .and. (len_trim(c)==0 .or. c(1:1)=='1')) then call write_inopt(star%np,'np'//trim(c),'number of particles',iunit) endif @@ -851,12 +843,11 @@ end subroutine write_options_star ! read setupfile options needed for a star !+ !----------------------------------------------------------------------- -subroutine read_options_star(star,ieos,db,nerr,label) +subroutine read_options_star(star,db,nerr,label) use infile_utils, only:inopts,read_inopt use setstar_utils, only:need_inputprofile,need_rstar,nprofile_opts type(star_t), intent(inout) :: star type(inopts), allocatable, intent(inout) :: db(:) - integer, intent(inout) :: ieos integer, intent(inout) :: nerr character(len=*), intent(in), optional :: label character(len=10) :: c @@ -870,8 +861,7 @@ subroutine read_options_star(star,ieos,db,nerr,label) star%dens_profile = 'relax'//trim(c)//'.profile' call read_inopt(star%iprofile,'iprofile'//trim(c),db,errcount=nerr,min=0,max=nprofile_opts) - call set_defaults_given_profile(star%iprofile,star%input_profile,& - ieos,star%m,star%polyk) + call set_defaults_given_profile(star%iprofile,star%input_profile,star%m,star%polyk) if (need_inputprofile(star%iprofile)) then call read_inopt(star%input_profile,'input_profile'//trim(c),db,errcount=nerr) @@ -922,12 +912,6 @@ subroutine read_options_star(star,ieos,db,nerr,label) if (need_polyk(star%iprofile)) call read_inopt(star%polyk,'polyk'//trim(c),db,errcount=nerr) - ! options for setting initial thermal energy (e.g. if degenerate matter eos) - select case(ieos) - case(15) - call read_inopt(star%initialtemp,'initialtemp'//trim(c),db,errcount=nerr,min=0.,max=1e12) - end select - ! star properties if (star%isoftcore <= 0) then if (need_inputprofile(star%iprofile)) then @@ -952,17 +936,18 @@ end subroutine read_options_star !----------------------------------------------------------------------- subroutine write_options_stars(star,relax,write_rho_to_file,ieos,iunit,nstar) use relaxstar, only:write_options_relax - use infile_utils, only:write_inopt + use infile_utils, only:write_inopt,int_to_string use apr, only:use_apr,write_options_apr type(star_t), intent(in) :: star(:) integer, intent(in) :: ieos,iunit logical, intent(in) :: relax,write_rho_to_file integer, intent(in), optional :: nstar integer :: i,nstars + character(len=3) :: label(size(star)) ! optionally ask for number of stars, otherwise fix nstars to the input array size if (present(nstar)) then - call write_inopt(nstar,'nstars','number of stars to add (0-'//achar(size(star)+48)//')',iunit) + call write_inopt(nstar,'nstars','number of stars to add (0-'//int_to_string(size(star))//')',iunit) nstars = nstar else nstars = size(star) @@ -970,18 +955,15 @@ subroutine write_options_stars(star,relax,write_rho_to_file,ieos,iunit,nstar) ! write options for each star do i=1,nstars - call write_options_star(star(i),ieos,iunit,label=achar(i+48)) + label(i) = trim(int_to_string(i)) + call write_options_star(star(i),iunit,label=label(i)) enddo - ! write equation of state options if any stars made of gas - if (nstars > 0) then - if (any(star(1:nstars)%iprofile > 0)) & - call write_options_stars_eos(star(1:nstars),ieos,iunit) - endif - - ! write relaxation options if any stars are made of gas + ! write equation of state and relaxation options if any stars made of gas if (nstars > 0) then if (any(star(1:nstars)%iprofile > 0)) then + call write_options_stars_eos(nstars,star(1:nstars),label(1:nstars),ieos,iunit) + write(iunit,"(/,a)") '# relaxation options' call write_inopt(relax,'relax','relax stars into equilibrium',iunit) call write_options_relax(iunit) @@ -1000,7 +982,7 @@ end subroutine write_options_stars !----------------------------------------------------------------------- subroutine read_options_stars(star,ieos,relax,write_rho_to_file,db,nerr,nstar) use relaxstar, only:read_options_relax - use infile_utils, only:inopts,read_inopt + use infile_utils, only:inopts,read_inopt,int_to_string use apr, only:use_apr,apr_max_in,ref_dir,apr_type,apr_rad,apr_drad type(star_t), intent(inout) :: star(:) ! inout because can set default options manually in calling routine type(inopts), allocatable, intent(inout) :: db(:) @@ -1009,6 +991,7 @@ subroutine read_options_stars(star,ieos,relax,write_rho_to_file,db,nerr,nstar) integer, intent(inout) :: nerr integer, intent(out), optional :: nstar integer :: i,nstars + character(len=3) :: label(size(star)) ! optionally ask for number of stars if (present(nstar)) then @@ -1018,19 +1001,19 @@ subroutine read_options_stars(star,ieos,relax,write_rho_to_file,db,nerr,nstar) nstars = size(star) endif - ! write equation of state options if any stars made of gas - if (nstars > 0) then - if (any(star(1:nstars)%iprofile > 0)) call read_options_stars_eos(star,ieos,db,nerr) - endif - ! read options for each star do i=1,nstars - call read_options_star(star(i),ieos,db,nerr,label=achar(i+48)) + label(i) = trim(int_to_string(i)) + call read_options_star(star(i),db,nerr,label=label(i)) enddo - ! read relaxation options if any stars are made of gas + ! equation of state and relaxation options if any stars made of gas if (nstars > 0) then if (any(star(1:nstars)%iprofile > 0)) then + if (any(star(1:nstars)%iprofile==ibpwpoly)) ieos = 9 ! set default eos for piecewise polytropes + ! equation of state options + call read_options_stars_eos(nstars,star(1:nstars),label(1:nstars),ieos,db,nerr) + ! relaxation options call read_inopt(relax,'relax',db,errcount=nerr) call read_options_relax(db,nerr) ! option to write density profile to file @@ -1053,11 +1036,13 @@ end subroutine read_options_stars ! write equation of state options needed to setup stars !+ !----------------------------------------------------------------------- -subroutine write_options_stars_eos(star,ieos,iunit) +subroutine write_options_stars_eos(nstars,star,label,ieos,iunit) use eos, only:use_var_comp,X_in,Z_in,irecomb,gmw,gamma use infile_utils, only:write_inopt - integer, intent(in) :: ieos,iunit - type(star_t), intent(in) :: star(:) + integer, intent(in) :: nstars,ieos,iunit + type(star_t), intent(in) :: star(nstars) + character(len=*), intent(in) :: label(nstars) + integer :: i write(iunit,"(/,a)") '# equation of state used to set the thermal energy profile' call write_inopt(ieos,'ieos','1=isothermal,2=adiabatic,10=MESA,12=idealplusrad',iunit) @@ -1079,6 +1064,14 @@ subroutine write_options_stars_eos(star,ieos,iunit) call write_inopt(X_in,'X','hydrogen mass fraction',iunit) call write_inopt(Z_in,'Z','metallicity',iunit) endif + case(15) + ! options for setting initial thermal energy (e.g. if degenerate matter eos) + do i=1,nstars + if (star(i)%iprofile > 0) then + call write_inopt(star(i)%initialtemp,'initialtemp'//trim(label(i)),& + 'initial temperature of star (e.g. if degenerate matter eos)',iunit) + endif + enddo end select end subroutine write_options_stars_eos @@ -1088,13 +1081,16 @@ end subroutine write_options_stars_eos ! read equation of state options needed to setup stars !+ !----------------------------------------------------------------------- -subroutine read_options_stars_eos(star,ieos,db,nerr) +subroutine read_options_stars_eos(nstars,star,label,ieos,db,nerr) use eos, only:use_var_comp,X_in,Z_in,irecomb,gamma,gmw use infile_utils, only:inopts,read_inopt - type(star_t), intent(out) :: star(:) + integer, intent(in) :: nstars + type(star_t), intent(inout) :: star(nstars) + character(len=*), intent(in) :: label(nstars) type(inopts), allocatable, intent(inout) :: db(:) integer, intent(inout) :: ieos integer, intent(inout) :: nerr + integer :: i ! equation of state call read_inopt(ieos,'ieos',db,errcount=nerr) @@ -1105,14 +1101,23 @@ subroutine read_options_stars_eos(star,ieos,db,nerr) call read_inopt(EOSopt,'EOSopt',db,min=0,max=4,errcount=nerr) case(2,12) call read_inopt(gamma,'gamma',db,min=1.,max=7.,errcount=nerr) - if ( (.not. use_var_comp) .and. any(need_mu(star(:)%isoftcore))) call read_inopt(gmw,'mu',db,min=0.,errcount=nerr) + if ((.not. use_var_comp) .and. any(need_mu(star(:)%isoftcore))) then + call read_inopt(gmw,'mu',db,min=0.,errcount=nerr) + endif case(10,20) if (ieos==20) call read_inopt(irecomb,'irecomb',db,errcount=nerr) ! if softening stellar core, composition is automatically determined at R/2 - if ( (.not. use_var_comp) .and. any(need_mu(star(:)%isoftcore))) then + if ((.not. use_var_comp) .and. any(need_mu(star(:)%isoftcore))) then call read_inopt(X_in,'X',db,min=0.,max=1.,errcount=nerr) call read_inopt(Z_in,'Z',db,min=0.,max=1.,errcount=nerr) endif + case(15) + do i=1,nstars + if (star(i)%iprofile > 0) then + call read_inopt(star(i)%initialtemp,'initialtemp'//trim(label(i)),& + db,min=0.,max=1e12,errcount=nerr) + endif + enddo end select end subroutine read_options_stars_eos diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index 449c4eecc..074d0473d 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -26,6 +26,7 @@ module setstar_utils ! Index of setup options ! integer, parameter, public :: nprofile_opts = 7 ! maximum number of initial configurations + integer, parameter, public :: ipointmass = 0 integer, parameter, public :: iuniform = 1 integer, parameter, public :: ipoly = 2 integer, parameter, public :: ifromfile = 3 @@ -34,8 +35,9 @@ module setstar_utils integer, parameter, public :: ibpwpoly = 6 integer, parameter, public :: ievrard = 7 - character(len=*), parameter, public :: profile_opt(nprofile_opts) = & - (/'Uniform density profile ', & + character(len=*), parameter, public :: profile_opt(0:nprofile_opts) = & + (/'Sink particle/point mass ', & + 'Uniform density sphere ', & 'Polytrope ', & 'Density vs r from ascii file', & 'KEPLER star from file ', & From 32b4b15b6927d926087426efd4465828d8569e96 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 9 Dec 2024 10:53:58 +1100 Subject: [PATCH 117/134] (build) buildbot now checks that all iprofile options work in SETUP=star; issues with piecewise polytrope fixed --- scripts/buildbot.sh | 42 +++++++++++++++++++++++++++--------------- src/setup/set_star.f90 | 5 ++++- 2 files changed, 31 insertions(+), 16 deletions(-) diff --git a/scripts/buildbot.sh b/scripts/buildbot.sh index 09a1c8e19..2d72f04b2 100755 --- a/scripts/buildbot.sh +++ b/scripts/buildbot.sh @@ -72,11 +72,12 @@ echo "url = $url"; pwd=$PWD; phantomdir="$pwd/../"; listofcomponents='main setup analysis utils'; -#listofcomponents='setup' +listofcomponents='setup' # # get list of targets, components and setups to check # allsetups=`grep 'ifeq ($(SETUP)' $phantomdir/build/Makefile_setups | grep -v skip | cut -d, -f 2 | cut -d')' -f 1` +allsetups='star' setuparr=($allsetups) batchsize=$(( ${#setuparr[@]} / $nbatch + 1 )) offset=$(( ($batch-1) * $batchsize )) @@ -197,11 +198,11 @@ check_phantomsetup () # run phantomsetup up to 3 times to successfully create/rewrite the .setup file # infile="${prefix}.in" - ./phantomsetup $prefix $flags < myinput.txt > /dev/null; - ./phantomsetup $prefix $flags < myinput.txt > /dev/null; + ./phantomsetup $prefix $flags < mycleanin.txt > /dev/null; + ./phantomsetup $prefix $flags < mycleanin.txt > /dev/null; if [ -e "$prefix.setup" ]; then print_result "creates .setup file" $pass; - #test_setupfile_options "$prefix" "$prefix.setup" $infile; + test_setupfile_options "$prefix.setup" "$flags" "$setup" $infile; else print_result "no .setup file" $warn; fi @@ -255,22 +256,33 @@ check_phantomsetup () test_setupfile_options() { myfail=0; - setup=$1; - setupfile=$2; - infile=$3; + #"$prefix.setup" "$flags" "$setup" $infile + setupfile=$1; + flags=$2; + setup=$3; + infile=$4; range='' - if [ "X$setup"=="Xstar" ]; then - param='iprofile' - range='1 2 3 4 5 6 7' + if [ "X$setup" == "Xstar" ]; then + param='iprofile1' + range='0 1 2 3 4 5 6 7' fi for x in $range; do valstring="$param = $x" - echo "checking $valstring" + echo "checking $valstring for SETUP=$setup" + rm $setupfile; + ./phantomsetup $setupfile $flags < mycleanin.txt > /dev/null; sed "s/$param.*=.*$/$valstring/" $setupfile > ${setupfile}.tmp - cp ${setupfile}.tmp $setupfile + mv ${setupfile}.tmp $setupfile + if [ "X$x" == "X6" ]; then + #sed "s/ieos.*=.*$/ieos = 9/" $setupfile > ${setupfile}.tmp + #mv ${setupfile}.tmp $setupfile + sed "s/dist_unit.*=.*$/dist_unit = km/" $setupfile > ${setupfile}.tmp + mv ${setupfile}.tmp $setupfile + fi + echo $setupfile rm $infile - ./phantomsetup $setupfile < /dev/null > /dev/null; - ./phantomsetup $setupfile < /dev/null; + ./phantomsetup $setupfile $flags < /dev/null > /dev/null; + ./phantomsetup $setupfile $flags < /dev/null > /dev/null; if [ -e $infile ]; then print_result "successful phantomsetup with $valstring" $pass; @@ -424,7 +436,7 @@ for setup in $listofsetups; do echo $setup >> $faillog; fi if [ -e $errorlogold ]; then - diff --unchanged-line-format="" --old-line-format="" --new-line-format="%L" $errorlogold $errorlog | tail -20 > warnings.tmp + diff $errorlogold $errorlog | tail -20 > warnings.tmp if [ -s warnings.tmp ]; then newwarn=1; else diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index a514bb1c1..ed726506d 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -438,7 +438,10 @@ subroutine set_stars(id,master,nstars,star,xyzh,vxyzu,eos_vars,rad,& procedure(mask_prototype) :: mask integer :: i - if (ieos==9) call init_eos_piecewise_preset(EOSopt) + ! initialise piecewise polytropic equation of state if piecewise polytrope used + if (ieos==9 .or. any(star(:)%iprofile==ibpwpoly)) call init_eos_piecewise_preset(EOSopt) + if (any(star(:)%iprofile==ibpwpoly)) call init_eos(9,ierr) + call init_eos(ieos,ierr) if (ierr /= 0) then call error('setup','could not initialise equation of state') From c2b0c670963cbcede6e32183997a18683d495943 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 9 Dec 2024 11:15:21 +1100 Subject: [PATCH 118/134] (grtde) build failures fixed --- src/setup/set_star.f90 | 3 +++ src/setup/setup_grtde.f90 | 12 +++++------- src/setup/setup_star.f90 | 2 +- 3 files changed, 9 insertions(+), 8 deletions(-) diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index ed726506d..f9b410d9b 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -733,6 +733,7 @@ subroutine set_stars_interactive(star,ieos,relax,nstar) ! optionally ask for number of stars, otherwise fix nstars to the input array size if (present(nstar) .and. size(star) > 1) then + nstar = 1 call prompt('how many stars to set up (0-'//int_to_string(size(star))//')',nstar,0,size(star)) nstars = nstar else @@ -749,6 +750,8 @@ subroutine set_stars_interactive(star,ieos,relax,nstar) if (any(star(1:nstars)%iprofile > 0)) then if (any(star(1:nstars)%iprofile==ibpwpoly)) ieos = 9 ! set default eos for piecewise polytropes call set_star_eos_interactive(ieos,star) + + relax = .false. call prompt('Relax stars automatically during setup?',relax) endif endif diff --git a/src/setup/setup_grtde.f90 b/src/setup/setup_grtde.f90 index bb25f7e19..1fb776d80 100644 --- a/src/setup/setup_grtde.f90 +++ b/src/setup/setup_grtde.f90 @@ -113,7 +113,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, norbits = 5. dumpsperorbit = 100 theta = 0. - write_profile = .false. + write_profile = .true. use_var_comp = .false. relax = .true. ! @@ -122,7 +122,7 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, if (id==master) print "(/,65('-'),1(/,a),/,65('-'),/)",' Tidal disruption in GR' filename = trim(fileprefix)//'.setup' inquire(file=filename,exist=iexist) - if (iexist) call read_setupfile(filename,ieos,ierr) + if (iexist) call read_setupfile(filename,ierr) if (.not. iexist .or. ierr /= 0) then if (id==master) then call write_setupfile(filename) @@ -250,14 +250,13 @@ subroutine write_setupfile(filename) use infile_utils, only:write_inopt use setstar, only:write_options_star use relaxstar, only:write_options_relax - use eos, only:ieos character(len=*), intent(in) :: filename integer :: iunit print "(a)",' writing setup options file '//trim(filename) open(newunit=iunit,file=filename,status='replace',form='formatted') write(iunit,"(a)") '# input file for tidal disruption setup' - call write_options_star(star,ieos,iunit) + call write_options_star(star,iunit) call write_inopt(relax,'relax','relax star into hydrostatic equilibrium',iunit) if (relax) call write_options_relax(iunit) @@ -272,7 +271,7 @@ subroutine write_setupfile(filename) end subroutine write_setupfile -subroutine read_setupfile(filename,ieos,ierr) +subroutine read_setupfile(filename,ierr) use infile_utils, only:open_db_from_file,inopts,read_inopt,close_db use io, only:error use setstar, only:read_options_star @@ -280,7 +279,6 @@ subroutine read_setupfile(filename,ieos,ierr) use physcon, only:solarm,solarr use units, only:set_units character(len=*), intent(in) :: filename - integer, intent(inout) :: ieos integer, intent(out) :: ierr integer, parameter :: iunit = 21 integer :: nerr @@ -298,7 +296,7 @@ subroutine read_setupfile(filename,ieos,ierr) ! !--read star options and convert to code units ! - call read_options_star(star,ieos,db,nerr) + call read_options_star(star,db,nerr) call read_inopt(relax,'relax',db,errcount=nerr) if (relax) call read_options_relax(db,nerr) diff --git a/src/setup/setup_star.f90 b/src/setup/setup_star.f90 index 288b8b119..67cdc057f 100644 --- a/src/setup/setup_star.f90 +++ b/src/setup/setup_star.f90 @@ -127,8 +127,8 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! if (.not.gravity) then iexternalforce = iext_densprofile - write_rho_to_file = .true. endif + write_rho_to_file = .true. ! ! set up particles ! From 304ab17de528906a687ad162f8d58b8dea483c1b Mon Sep 17 00:00:00 2001 From: ryosuke-hirai Date: Mon, 9 Dec 2024 17:54:57 +1100 Subject: [PATCH 119/134] (readwrite_mesa) Add a few more options for column names --- src/setup/readwrite_mesa.f90 | 22 ++++++++++++++++++---- 1 file changed, 18 insertions(+), 4 deletions(-) diff --git a/src/setup/readwrite_mesa.f90 b/src/setup/readwrite_mesa.f90 index d69a8ff72..e72c313e8 100644 --- a/src/setup/readwrite_mesa.f90 +++ b/src/setup/readwrite_mesa.f90 @@ -101,8 +101,9 @@ subroutine read_mesa(filepath,rho,r,pres,m,ene,temp,X_in,Z_in,Xfrac,Yfrac,Mstar, call read_column_labels(iu,nheaderlines,ncols,nlabels,header) if (nlabels /= ncols) print*,' WARNING: different number of labels compared to columns' - allocate(m(lines),r(lines),pres(lines),rho(lines),ene(lines), & - temp(lines),Xfrac(lines),Yfrac(lines)) + allocate(m(lines)) + m = -1d0 + allocate(r,pres,rho,ene,temp,Xfrac,Yfrac,source=m) over_directions: do idir=1,2 ! try backwards, then forwards if (idir==1) then @@ -152,12 +153,18 @@ subroutine read_mesa(filepath,rho,r,pres,m,ene,temp,X_in,Z_in,Xfrac,Yfrac,Mstar, r = (10**dat(1:lines,i)) * solarr case('pressure','p') pres = dat(1:lines,i) + case('logP') + pres = 10**dat(1:lines,i) case('temperature','t') temp = dat(1:lines,i) - case('x_mass_fraction_h','xfrac') + case('x_mass_fraction_h','x_mass_fraction_H','x','xfrac','h1') Xfrac = dat(1:lines,i) - case('y_mass_fraction_he','yfrac') + case('log_x') + Xfrac = 10**dat(1:lines,i) + case('y_mass_fraction_he','y_mass_fraction_He','y','yfrac','he4') Yfrac = dat(1:lines,i) + case('log_y') + Yfrac = 10**dat(1:lines,i) case default got_column = .false. end select @@ -176,6 +183,13 @@ subroutine read_mesa(filepath,rho,r,pres,m,ene,temp,X_in,Z_in,Xfrac,Yfrac,Mstar, enddo over_directions close(iu) + if(min(minval(m),minval(r),minval(pres),minval(rho),minval(ene))<0d0)ierr = 1 + + if (ierr /= 0) then + print "(a,/)",' ERROR reading MESA file [missing required columns]' + return + endif + if (.not. usecgs) then m = m / umass r = r / udist From 9e0a59ab56fa7beb72ffae465a5936eb88752fdf Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 9 Dec 2024 18:09:01 +1100 Subject: [PATCH 120/134] BUG FIX: fixes #604 where star would fail to relax if Mstar /= 1; incorrect divide-by-mstar in relaxation routine --- src/setup/relax_star.f90 | 2 +- src/tests/test_setstar.f90 | 10 ++++++---- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/src/setup/relax_star.f90 b/src/setup/relax_star.f90 index c05c2deaa..b8acc853b 100644 --- a/src/setup/relax_star.f90 +++ b/src/setup/relax_star.f90 @@ -421,7 +421,7 @@ subroutine reset_u_and_get_errors(i1,npart,xyzh,vxyzu,rad,nt,mr,rho,& do i = i1+1,npart ri = sqrt(dot_product(xyzh(1:3,i),xyzh(1:3,i))) - massri = mass_enclosed_r(i-i1)/mstar + massri = mass_enclosed_r(i-i1) rhor = yinterp(rho,mr,massri) ! analytic rho(r) if (use_apr) then diff --git a/src/tests/test_setstar.f90 b/src/tests/test_setstar.f90 index 43f6b3468..a847e9e2e 100644 --- a/src/tests/test_setstar.f90 +++ b/src/tests/test_setstar.f90 @@ -145,10 +145,12 @@ subroutine test_polytrope(ntests,npass) npartoftype = 0 massoftype = 0. iverbose = 0 - call set_units(dist=solarr,mass=solarm,G=1.d0) + call set_units(dist=10.*solarr,mass=10.*solarm,G=1.d0) ieos = 2 gamma = 5./3. call set_defaults_star(star) + star%m = '1*msun' + star%r = '1*rsun' star%iprofile = ipoly ! a polytrope star%np = 1000 x0 = 0. @@ -170,13 +172,13 @@ subroutine test_polytrope(ntests,npass) call checkval(nerror+nwarn,0,0,nfail(1),'no errors or warnings') call update_test_scores(ntests,nfail,npass) - call checkval(rhozero,1./(4./3.*pi),1e-6,nfail(1),'mean density') + call checkval(rhozero,100./(4./3.*pi),1e-6,nfail(1),'mean density') call update_test_scores(ntests,nfail,npass) - call checkval(star%polyk,0.424304,1e-6,nfail(1),'polyk value for M=1,R=1') + call checkval(star%polyk,1.9694457e-2,1e-6,nfail(1),'polyk value for M=0.1,R=0.1') call update_test_scores(ntests,nfail,npass) - call checkval(polyk,0.424304,1e-6,nfail(1),'polyk value for M=1,R=1') + call checkval(polyk,1.9694457e-2,1e-6,nfail(1),'polyk value for M=0.1,R=0.1') call update_test_scores(ntests,nfail,npass) call checkval(rmserr,0.0,0.04,nfail(1),'error in density profile') From 121b48f015129ff481357ac61860173e469b5d97 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 9 Dec 2024 18:15:34 +1100 Subject: [PATCH 121/134] [header-bot] updated file headers --- src/main/extern_densprofile.f90 | 2 +- src/main/relaxem.f90 | 2 +- src/setup/relax_star.f90 | 3 +-- src/setup/set_star.f90 | 20 +++++++++++++++----- src/setup/set_star_utils.f90 | 4 ++-- src/setup/setup_binary.f90 | 2 +- src/setup/setup_star.f90 | 21 ++++----------------- src/tests/test_apr.f90 | 4 ++-- src/tests/test_setstar.f90 | 4 +++- src/tests/testsuite.F90 | 2 +- 10 files changed, 31 insertions(+), 33 deletions(-) diff --git a/src/main/extern_densprofile.f90 b/src/main/extern_densprofile.f90 index 2a78573a6..b759a311a 100644 --- a/src/main/extern_densprofile.f90 +++ b/src/main/extern_densprofile.f90 @@ -16,7 +16,7 @@ module extern_densprofile ! ! :Runtime parameters: None ! -! :Dependencies: datafiles, io, physcon, units +! :Dependencies: datafiles, io, physcon, table_utils, units ! implicit none diff --git a/src/main/relaxem.f90 b/src/main/relaxem.f90 index 417896bf1..f7cfe238f 100644 --- a/src/main/relaxem.f90 +++ b/src/main/relaxem.f90 @@ -14,7 +14,7 @@ module relaxem ! ! :Runtime parameters: None ! -! :Dependencies: boundary, deriv, dim, eos, kernel, mpidomain, options, +! :Dependencies: boundary, deriv, dim, eos, io, kernel, mpidomain, options, ! part ! implicit none diff --git a/src/setup/relax_star.f90 b/src/setup/relax_star.f90 index b8acc853b..3512837cc 100644 --- a/src/setup/relax_star.f90 +++ b/src/setup/relax_star.f90 @@ -20,8 +20,7 @@ module relaxstar ! :Dependencies: apr, checksetup, damping, deriv, dim, dump_utils, ! energies, eos, externalforces, fileutils, infile_utils, initial, io, ! io_summary, linklist, memory, options, part, physcon, ptmass, -! readwrite_dumps, setstar_utils, sortutils, step_lf_global, table_utils, -! units +! readwrite_dumps, setstar_utils, step_lf_global, table_utils, units ! implicit none public :: relax_star,write_options_relax,read_options_relax diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index f9b410d9b..b44e124f9 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -16,12 +16,22 @@ module setstar ! :Owner: Daniel Price ! ! :Runtime parameters: -! - nstars : *number of stars to add (0-'//achar(size(star)+48)//')* -! - relax : *relax stars into equilibrium* +! - EOSopt : *EOS: 1=APR3,2=SLy,3=MS1,4=ENG (from Read et al 2009)* +! - X : *hydrogen mass fraction* +! - gamma : *Adiabatic index* +! - ieos : *1=isothermal,2=adiabatic,10=MESA,12=idealplusrad* +! - irecomb : *Species to include in recombination (0: H2+H+He, 1:H+He, 2:He* +! - metallicity : *metallicity* +! - mu : *mean molecular weight* +! - nstars : *number of stars to add (0-'//int_to_string(size(star))//')* +! - relax : *relax stars into equilibrium* +! - use_var_comp : *Use variable composition (X, Z, mu)* +! - write_rho_to_file : *write density profile(s) to file* ! -! :Dependencies: centreofmass, dim, eos, extern_densprofile, infile_utils, -! io, mpiutils, part, physcon, prompting, radiation_utils, relaxstar, -! setstar_utils, unifdis, units, vectorutils +! :Dependencies: apr, centreofmass, dim, eos, eos_piecewise, +! extern_densprofile, infile_utils, io, mpiutils, part, physcon, +! prompting, radiation_utils, relaxstar, setstar_utils, unifdis, units, +! vectorutils ! use setstar_utils, only:ikepler,imesa,ibpwpoly,ipoly,iuniform,ifromfile,ievrard,& need_polyk,need_mu diff --git a/src/setup/set_star_utils.f90 b/src/setup/set_star_utils.f90 index 074d0473d..7ac2f2e18 100644 --- a/src/setup/set_star_utils.f90 +++ b/src/setup/set_star_utils.f90 @@ -14,8 +14,8 @@ module setstar_utils ! ! :Runtime parameters: None ! -! :Dependencies: eos, eos_piecewise, extern_densprofile, io, kernel, part, -! physcon, radiation_utils, readwrite_kepler, readwrite_mesa, +! :Dependencies: dim, eos, eos_piecewise, extern_densprofile, io, kernel, +! part, physcon, radiation_utils, readwrite_kepler, readwrite_mesa, ! rho_profile, setsoftenedcore, sortutils, spherical, table_utils, ! unifdis, units ! diff --git a/src/setup/setup_binary.f90 b/src/setup/setup_binary.f90 index 5bebb3c3f..37d450fbf 100644 --- a/src/setup/setup_binary.f90 +++ b/src/setup/setup_binary.f90 @@ -17,7 +17,7 @@ module setup ! ! :Dependencies: centreofmass, dim, eos, externalforces, infile_utils, io, ! kernel, mpidomain, options, part, physcon, setorbit, setstar, setunits, -! setup_params +! setup_params, units ! use setstar, only:star_t use setorbit, only:orbit_t diff --git a/src/setup/setup_star.f90 b/src/setup/setup_star.f90 index 67cdc057f..7fd11ef99 100644 --- a/src/setup/setup_star.f90 +++ b/src/setup/setup_star.f90 @@ -12,24 +12,11 @@ module setup ! ! :Owner: Daniel Price ! -! :Runtime parameters: -! - EOSopt : *EOS: 1=APR3,2=SLy,3=MS1,4=ENG (from Read et al 2009)* -! - X : *hydrogen mass fraction* -! - gamma : *Adiabatic index* -! - ieos : *1=isothermal,2=adiabatic,10=MESA,12=idealplusrad* -! - initialtemp : *initial temperature of the star* -! - irecomb : *Species to include in recombination (0: H2+H+He, 1:H+He, 2:He* -! - metallicity : *metallicity* -! - mu : *mean molecular weight* -! - polyk : *polytropic constant (cs^2 if isothermal)* -! - relax_star : *relax star(s) automatically during setup* -! - use_var_comp : *Use variable composition (X, Z, mu)* -! - write_rho_to_file : *write density profile(s) to file* +! :Runtime parameters: None ! -! :Dependencies: apr, dim, eos, eos_gasradrec, eos_piecewise, -! extern_densprofile, externalforces, infile_utils, io, kernel, -! mpidomain, mpiutils, options, part, physcon, prompting, relaxstar, -! setstar, setunits, setup_params, timestep, units +! :Dependencies: dim, eos, externalforces, infile_utils, io, kernel, +! mpidomain, options, part, physcon, setstar, setunits, setup_params, +! timestep ! use io, only:fatal,error,warning,master use part, only:gravity,gr diff --git a/src/tests/test_apr.f90 b/src/tests/test_apr.f90 index 002768959..eebb5c0f5 100644 --- a/src/tests/test_apr.f90 +++ b/src/tests/test_apr.f90 @@ -14,8 +14,8 @@ module testapr ! ! :Runtime parameters: None ! -! :Dependencies: apr, boundary, dim, io, linklist, mpidomain, mpiutils, -! part, physcon, testutils, unifdis, units +! :Dependencies: apr, boundary, dim, io, mpidomain, mpiutils, part, +! testutils, unifdis ! use testutils, only:checkval,update_test_scores use io, only:id,master,fatal diff --git a/src/tests/test_setstar.f90 b/src/tests/test_setstar.f90 index a847e9e2e..a68ffb84a 100644 --- a/src/tests/test_setstar.f90 +++ b/src/tests/test_setstar.f90 @@ -14,7 +14,9 @@ module testsetstar ! ! :Runtime parameters: None ! -! :Dependencies: +! :Dependencies: checksetup, dim, eos, io, mpidomain, options, part, +! physcon, setstar, setstar_utils, sortutils, table_utils, testutils, +! units ! use testutils, only:checkval,update_test_scores implicit none diff --git a/src/tests/testsuite.F90 b/src/tests/testsuite.F90 index e66c73210..86db01be7 100644 --- a/src/tests/testsuite.F90 +++ b/src/tests/testsuite.F90 @@ -21,7 +21,7 @@ module test ! testgrowth, testindtstep, testiorig, testkdtree, testkernel, testlink, ! testmath, testmpi, testnimhd, testpart, testpoly, testptmass, ! testradiation, testrwdump, testsedov, testsetdisc, testsethier, -! testsmol, teststep, testwind, timing +! testsetstar, testsmol, teststep, testwind, timing ! implicit none public :: testsuite From 1b9a59b1e6c53b697eca6f82bbf06e6abda1f897 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 9 Dec 2024 18:15:52 +1100 Subject: [PATCH 122/134] [space-bot] whitespace at end of lines removed --- src/setup/set_star.f90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index b44e124f9..a73b411ed 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -754,7 +754,7 @@ subroutine set_stars_interactive(star,ieos,relax,nstar) print "(/,'------------- STAR ',i0,'-------------')",i call set_star_interactive(star(i)) enddo - + ! prompt for equation of state and relaxation options if any stars made of gas if (nstars > 0) then if (any(star(1:nstars)%iprofile > 0)) then @@ -765,7 +765,7 @@ subroutine set_stars_interactive(star,ieos,relax,nstar) call prompt('Relax stars automatically during setup?',relax) endif endif - + end subroutine set_stars_interactive !----------------------------------------------------------------------- @@ -1031,9 +1031,9 @@ subroutine read_options_stars(star,ieos,relax,write_rho_to_file,db,nerr,nstar) call read_options_stars_eos(nstars,star(1:nstars),label(1:nstars),ieos,db,nerr) ! relaxation options call read_inopt(relax,'relax',db,errcount=nerr) - call read_options_relax(db,nerr) + call read_options_relax(db,nerr) ! option to write density profile to file - call read_inopt(write_rho_to_file,'write_rho_to_file',db,errcount=nerr) + call read_inopt(write_rho_to_file,'write_rho_to_file',db,errcount=nerr) endif endif From 3c9315e2f3aac764f38bd6e625173592d0add81c Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 9 Dec 2024 18:16:34 +1100 Subject: [PATCH 123/134] [indent-bot] standardised indentation --- src/setup/set_star.f90 | 24 ++++++++++++------------ src/setup/setup_grdisc.F90 | 38 +++++++++++++++++++------------------- 2 files changed, 31 insertions(+), 31 deletions(-) diff --git a/src/setup/set_star.f90 b/src/setup/set_star.f90 index a73b411ed..52a412be1 100644 --- a/src/setup/set_star.f90 +++ b/src/setup/set_star.f90 @@ -1038,11 +1038,11 @@ subroutine read_options_stars(star,ieos,relax,write_rho_to_file,db,nerr,nstar) endif if (use_apr) then - call read_inopt(apr_max_in,'apr_max',db,errcount=nerr) - call read_inopt(ref_dir,'ref_dir',db,errcount=nerr) - call read_inopt(apr_type,'apr_type',db,errcount=nerr) - call read_inopt(apr_rad,'apr_rad',db,errcount=nerr) - call read_inopt(apr_drad,'apr_drad',db,errcount=nerr) + call read_inopt(apr_max_in,'apr_max',db,errcount=nerr) + call read_inopt(ref_dir,'ref_dir',db,errcount=nerr) + call read_inopt(apr_type,'apr_type',db,errcount=nerr) + call read_inopt(apr_rad,'apr_rad',db,errcount=nerr) + call read_inopt(apr_drad,'apr_drad',db,errcount=nerr) endif end subroutine read_options_stars @@ -1081,13 +1081,13 @@ subroutine write_options_stars_eos(nstars,star,label,ieos,iunit) call write_inopt(Z_in,'Z','metallicity',iunit) endif case(15) - ! options for setting initial thermal energy (e.g. if degenerate matter eos) - do i=1,nstars - if (star(i)%iprofile > 0) then - call write_inopt(star(i)%initialtemp,'initialtemp'//trim(label(i)),& + ! options for setting initial thermal energy (e.g. if degenerate matter eos) + do i=1,nstars + if (star(i)%iprofile > 0) then + call write_inopt(star(i)%initialtemp,'initialtemp'//trim(label(i)),& 'initial temperature of star (e.g. if degenerate matter eos)',iunit) - endif - enddo + endif + enddo end select end subroutine write_options_stars_eos @@ -1167,7 +1167,7 @@ subroutine set_star_eos_interactive(ieos,star) if ( (.not. use_var_comp) .and. any(need_mu(star(:)%isoftcore))) then call prompt('Enter hydrogen mass fraction (X)',X_in,0.,1.) call prompt('Enter metals mass fraction (Z)',Z_in,0.,1.) - endif + endif end select end subroutine set_star_eos_interactive diff --git a/src/setup/setup_grdisc.F90 b/src/setup/setup_grdisc.F90 index 00ef2c139..605d9daa3 100644 --- a/src/setup/setup_grdisc.F90 +++ b/src/setup/setup_grdisc.F90 @@ -169,31 +169,31 @@ subroutine setpart(id,npart,npartoftype,xyzh,massoftype,vxyzu,polyk,gamma,hfact, ! either sink particles or balls of gas ! if (nstars > 0) then - write_profile = .false. - iexternalforce = 0 - call set_stars(id,master,nstars,star,xyzh,vxyzu,eos_vars,rad,npart,npartoftype,& + write_profile = .false. + iexternalforce = 0 + call set_stars(id,master,nstars,star,xyzh,vxyzu,eos_vars,rad,npart,npartoftype,& massoftype,hfact,xyzmh_ptmass,vxyz_ptmass,nptmass,ieos,gamma,& X_in,Z_in,relax,use_var_comp,write_profile,& rhozero,npart_total,i_belong,ierr) - do i=1,nstars - nptmass_in = 0 - ! convert stellar mass and radius to code units - mstar = in_code_units(star(i)%m,ierr) - rstar = in_code_units(star(i)%r,ierr) - call set_orbit(orbit(i),mhole/umass,mstar,r_in,rstar, & + do i=1,nstars + nptmass_in = 0 + ! convert stellar mass and radius to code units + mstar = in_code_units(star(i)%m,ierr) + rstar = in_code_units(star(i)%r,ierr) + call set_orbit(orbit(i),mhole/umass,mstar,r_in,rstar, & xyzmh_ptmass_in,vxyz_ptmass_in,nptmass_in,(id==master),ierr) - ! shift the star to the position of the second body - if (star(i)%iprofile > 0) then - call shift_star(npart,npartoftype,xyzh,vxyzu,& + ! shift the star to the position of the second body + if (star(i)%iprofile > 0) then + call shift_star(npart,npartoftype,xyzh,vxyzu,& x0=xyzmh_ptmass_in(:,2),v0=vxyz_ptmass_in(:,2),itype=i) - else - nptmass = nptmass + 1 - xyzmh_ptmass(:,nptmass) = xyzmh_ptmass_in(:,2) - vxyz_ptmass(:,nptmass) = vxyz_ptmass_in(:,2) - endif - enddo -endif + else + nptmass = nptmass + 1 + xyzmh_ptmass(:,nptmass) = xyzmh_ptmass_in(:,2) + vxyz_ptmass(:,nptmass) = vxyz_ptmass_in(:,2) + endif + enddo + endif #ifndef GR iexternalforce = iext_einsteinprec From 9c5df94dad81a2ad17e4360327e156295f74da7d Mon Sep 17 00:00:00 2001 From: ryosuke-hirai Date: Mon, 9 Dec 2024 18:18:13 +1100 Subject: [PATCH 124/134] (readwrite_mesa) Add a few more options for column names --- src/setup/readwrite_mesa.f90 | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/src/setup/readwrite_mesa.f90 b/src/setup/readwrite_mesa.f90 index e72c313e8..8e02843a5 100644 --- a/src/setup/readwrite_mesa.f90 +++ b/src/setup/readwrite_mesa.f90 @@ -138,25 +138,36 @@ subroutine read_mesa(filepath,rho,r,pres,m,ene,temp,X_in,Z_in,Xfrac,Yfrac,Mstar, case('mass','#mass','m') m = dat(1:lines,i) if (ismesafile .or. maxval(m) < 1.e-10*solarm) m = m * solarm ! If reading MESA profile, 'mass' is in units of Msun + case('logM','log_mass') + m = 10**dat(1:lines,i) + if (ismesafile .or. maxval(m) < 1.e-10*solarm) m = m * solarm ! If reading MESA profile, 'mass' is in units of Msun case('rho','density') rho = dat(1:lines,i) - case('logrho') + case('logrho','logRho') rho = 10**(dat(1:lines,i)) case('energy','e_int','e_internal') ene = dat(1:lines,i) + case('logE') + ene = 10**dat(1:lines,i) case('radius_cm') r = dat(1:lines,i) + case('radius_km') + r = dat(1:lines,i) * 1e5 case('radius','r') r = dat(1:lines,i) if (ismesafile .or. maxval(r) < 1e-10*solarr) r = r * solarr - case('logr') + case('logr','logR') r = (10**dat(1:lines,i)) * solarr + case('logR_cm') + r = 10**dat(1:lines,i) case('pressure','p') pres = dat(1:lines,i) case('logP') pres = 10**dat(1:lines,i) case('temperature','t') temp = dat(1:lines,i) + case('logT') + temp = 10**dat(1:lines,i) case('x_mass_fraction_h','x_mass_fraction_H','x','xfrac','h1') Xfrac = dat(1:lines,i) case('log_x') From 60af9b289c9930c00a61f2ed5a31362fc6dab76b Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 9 Dec 2024 20:45:07 +1100 Subject: [PATCH 125/134] (build) check all setups; remove debugging line --- scripts/buildbot.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scripts/buildbot.sh b/scripts/buildbot.sh index 2d72f04b2..9b8b7df51 100755 --- a/scripts/buildbot.sh +++ b/scripts/buildbot.sh @@ -77,7 +77,7 @@ listofcomponents='setup' # get list of targets, components and setups to check # allsetups=`grep 'ifeq ($(SETUP)' $phantomdir/build/Makefile_setups | grep -v skip | cut -d, -f 2 | cut -d')' -f 1` -allsetups='star' +#allsetups='star' setuparr=($allsetups) batchsize=$(( ${#setuparr[@]} / $nbatch + 1 )) offset=$(( ($batch-1) * $batchsize )) From bab66c9c6c7ee9610a6a62cf37399efb688afcf5 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Mon, 9 Dec 2024 20:45:34 +1100 Subject: [PATCH 126/134] (build) check all setups+components; remove debugging line --- scripts/buildbot.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scripts/buildbot.sh b/scripts/buildbot.sh index 9b8b7df51..3a51adc0e 100755 --- a/scripts/buildbot.sh +++ b/scripts/buildbot.sh @@ -72,7 +72,7 @@ echo "url = $url"; pwd=$PWD; phantomdir="$pwd/../"; listofcomponents='main setup analysis utils'; -listofcomponents='setup' +#listofcomponents='setup' # # get list of targets, components and setups to check # From 8987fae27075cf251aba2d431519dee7f158104e Mon Sep 17 00:00:00 2001 From: Alison Young Date: Mon, 9 Dec 2024 16:52:48 +0000 Subject: [PATCH 127/134] Edit for GitHub build --- src/setup/setup_disc.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/setup/setup_disc.f90 b/src/setup/setup_disc.f90 index 9bd332979..87e5381ce 100644 --- a/src/setup/setup_disc.f90 +++ b/src/setup/setup_disc.f90 @@ -2271,7 +2271,7 @@ subroutine setup_interactive(id) endif if (lumdisc > 0) then !get luminosity ... - call prompt("Enter the luminosity of star",L_star(i)) + call prompt("Enter the luminosity of star",L_star(1)) call prompt("Enter the background temperature e.g. 10 (K)", T_bg) qindex(1) = 0.25 qindex = 0.25 From 59824d339191c5bc0000aaab7b286fae04daa2da Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 10 Dec 2024 08:22:03 +1100 Subject: [PATCH 128/134] (blob) build failure in single precision fixed --- src/main/units.f90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/main/units.f90 b/src/main/units.f90 index 9aa59d101..a859c768d 100644 --- a/src/main/units.f90 +++ b/src/main/units.f90 @@ -307,7 +307,7 @@ end subroutine select_unit logical function is_time_unit(string) character(len=*), intent(in) :: string character(len=len_utype) :: unit_type - real :: val + real(kind=8) :: val integer :: ierr ierr = 0 @@ -325,7 +325,7 @@ end function is_time_unit logical function is_length_unit(string) character(len=*), intent(in) :: string character(len=len_utype) :: unit_type - real :: val + real(kind=8) :: val integer :: ierr ierr = 0 @@ -343,7 +343,7 @@ end function is_length_unit logical function is_mdot_unit(string) character(len=*), intent(in) :: string character(len=len_utype) :: unit_type - real :: val + real(kind=8) :: val integer :: ierr ierr = 0 @@ -580,7 +580,7 @@ real(kind=8) function in_units(val,unitstring) result(rval) character(len=*), intent(in) :: unitstring character(len=len_utype) :: utype integer :: ierr - real :: fac + real(kind=8) :: fac call select_unit(unitstring,fac,ierr,unit_type=utype) ! handle errors silently by ignoring ierr From 6af713194881de68cbe5eee247ce7dc19ddd7d20 Mon Sep 17 00:00:00 2001 From: Daniel Price Date: Tue, 10 Dec 2024 08:57:46 +1100 Subject: [PATCH 129/134] build failure with default filename in extern_densprofile fixed --- src/main/extern_densprofile.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/extern_densprofile.f90 b/src/main/extern_densprofile.f90 index b759a311a..c106668f8 100644 --- a/src/main/extern_densprofile.f90 +++ b/src/main/extern_densprofile.f90 @@ -25,7 +25,7 @@ module extern_densprofile integer, public :: ntab ! *** Add option to .in file to specify density profile / mass enclosed filename? *** - character(len=*), public, parameter :: rhotabfile = 'density-profile.tab' + character(len=*), public, parameter :: rhotabfile = 'relax1.profile' integer, public, parameter :: nrhotab = 5000 ! maximum allowed size of r rho tabulated arrays public :: densityprofile_force, load_extern_densityprofile, read_rhotab, write_rhotab, calc_menc From 559c3cec7594094bd3dc065f8d9d8e39edbd382b Mon Sep 17 00:00:00 2001 From: ryosuke-hirai Date: Tue, 10 Dec 2024 12:29:09 +1100 Subject: [PATCH 130/134] (readwrite_mesa) loosen error criterion --- src/setup/readwrite_mesa.f90 | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/setup/readwrite_mesa.f90 b/src/setup/readwrite_mesa.f90 index 8e02843a5..22fdf8733 100644 --- a/src/setup/readwrite_mesa.f90 +++ b/src/setup/readwrite_mesa.f90 @@ -102,7 +102,7 @@ subroutine read_mesa(filepath,rho,r,pres,m,ene,temp,X_in,Z_in,Xfrac,Yfrac,Mstar, if (nlabels /= ncols) print*,' WARNING: different number of labels compared to columns' allocate(m(lines)) - m = -1d0 + m = -1. allocate(r,pres,rho,ene,temp,Xfrac,Yfrac,source=m) over_directions: do idir=1,2 ! try backwards, then forwards @@ -143,11 +143,11 @@ subroutine read_mesa(filepath,rho,r,pres,m,ene,temp,X_in,Z_in,Xfrac,Yfrac,Mstar, if (ismesafile .or. maxval(m) < 1.e-10*solarm) m = m * solarm ! If reading MESA profile, 'mass' is in units of Msun case('rho','density') rho = dat(1:lines,i) - case('logrho','logRho') + case('logrho') rho = 10**(dat(1:lines,i)) case('energy','e_int','e_internal') ene = dat(1:lines,i) - case('logE') + case('logr') ene = 10**dat(1:lines,i) case('radius_cm') r = dat(1:lines,i) @@ -156,23 +156,23 @@ subroutine read_mesa(filepath,rho,r,pres,m,ene,temp,X_in,Z_in,Xfrac,Yfrac,Mstar, case('radius','r') r = dat(1:lines,i) if (ismesafile .or. maxval(r) < 1e-10*solarr) r = r * solarr - case('logr','logR') + case('logr') r = (10**dat(1:lines,i)) * solarr - case('logR_cm') + case('logr_cm') r = 10**dat(1:lines,i) case('pressure','p') pres = dat(1:lines,i) - case('logP') + case('logp') pres = 10**dat(1:lines,i) case('temperature','t') temp = dat(1:lines,i) - case('logT') + case('logt') temp = 10**dat(1:lines,i) - case('x_mass_fraction_h','x_mass_fraction_H','x','xfrac','h1') + case('x_mass_fraction_h','x','xfrac','h1') Xfrac = dat(1:lines,i) case('log_x') Xfrac = 10**dat(1:lines,i) - case('y_mass_fraction_he','y_mass_fraction_He','y','yfrac','he4') + case('y_mass_fraction_he','y','yfrac','he4') Yfrac = dat(1:lines,i) case('log_y') Yfrac = 10**dat(1:lines,i) @@ -194,7 +194,7 @@ subroutine read_mesa(filepath,rho,r,pres,m,ene,temp,X_in,Z_in,Xfrac,Yfrac,Mstar, enddo over_directions close(iu) - if(min(minval(m),minval(r),minval(pres),minval(rho),minval(ene))<0d0)ierr = 1 + if(min(minval(m),minval(r),minval(pres),minval(rho))<0d0)ierr = 1 if (ierr /= 0) then print "(a,/)",' ERROR reading MESA file [missing required columns]' From dcbf82af608b16d699df4966a32efdb3f5efd5ea Mon Sep 17 00:00:00 2001 From: ryosuke-hirai Date: Tue, 10 Dec 2024 12:30:47 +1100 Subject: [PATCH 131/134] (readwrite_mesa) fix typo --- src/setup/readwrite_mesa.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/setup/readwrite_mesa.f90 b/src/setup/readwrite_mesa.f90 index 22fdf8733..78de7ffca 100644 --- a/src/setup/readwrite_mesa.f90 +++ b/src/setup/readwrite_mesa.f90 @@ -147,7 +147,7 @@ subroutine read_mesa(filepath,rho,r,pres,m,ene,temp,X_in,Z_in,Xfrac,Yfrac,Mstar, rho = 10**(dat(1:lines,i)) case('energy','e_int','e_internal') ene = dat(1:lines,i) - case('logr') + case('loge') ene = 10**dat(1:lines,i) case('radius_cm') r = dat(1:lines,i) From dd9251f81873d8fb88a329c3957754d77959d3b4 Mon Sep 17 00:00:00 2001 From: ryosuke-hirai Date: Tue, 10 Dec 2024 12:36:32 +1100 Subject: [PATCH 132/134] (readwrite_mesa) loosen error criterion --- src/setup/readwrite_mesa.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/setup/readwrite_mesa.f90 b/src/setup/readwrite_mesa.f90 index 78de7ffca..3329edef4 100644 --- a/src/setup/readwrite_mesa.f90 +++ b/src/setup/readwrite_mesa.f90 @@ -194,7 +194,7 @@ subroutine read_mesa(filepath,rho,r,pres,m,ene,temp,X_in,Z_in,Xfrac,Yfrac,Mstar, enddo over_directions close(iu) - if(min(minval(m),minval(r),minval(pres),minval(rho))<0d0)ierr = 1 + if(min(minval(r),minval(pres),minval(rho))<0d0)ierr = 1 if (ierr /= 0) then print "(a,/)",' ERROR reading MESA file [missing required columns]' From ae882611681812e7507388a8e85bc9b0faaffc1c Mon Sep 17 00:00:00 2001 From: ryosuke-hirai Date: Tue, 10 Dec 2024 12:37:44 +1100 Subject: [PATCH 133/134] (readwrite_mesa) loosen error criterion --- src/setup/readwrite_mesa.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/setup/readwrite_mesa.f90 b/src/setup/readwrite_mesa.f90 index 3329edef4..70bb69dbd 100644 --- a/src/setup/readwrite_mesa.f90 +++ b/src/setup/readwrite_mesa.f90 @@ -194,7 +194,7 @@ subroutine read_mesa(filepath,rho,r,pres,m,ene,temp,X_in,Z_in,Xfrac,Yfrac,Mstar, enddo over_directions close(iu) - if(min(minval(r),minval(pres),minval(rho))<0d0)ierr = 1 + if(min(minval(pres),minval(rho))<0d0)ierr = 1 if (ierr /= 0) then print "(a,/)",' ERROR reading MESA file [missing required columns]' From d580376122967688065c6b6eefe3035d1e20bf9e Mon Sep 17 00:00:00 2001 From: Alison Young Date: Tue, 10 Dec 2024 09:23:05 +0000 Subject: [PATCH 134/134] Edits for GitHub build --- src/utils/analysis_disc_stresses.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/utils/analysis_disc_stresses.f90 b/src/utils/analysis_disc_stresses.f90 index 8fe638193..928403471 100644 --- a/src/utils/analysis_disc_stresses.f90 +++ b/src/utils/analysis_disc_stresses.f90 @@ -369,7 +369,7 @@ subroutine radial_binning(npart,xyzh,vxyzu,pmass,eos_vars) real,intent(in) :: pmass real,intent(in) :: xyzh(:,:),vxyzu(:,:),eos_vars(:,:) - integer :: ibin,ipart,nbinned,iallocerr,ierr + integer :: ibin,ipart,nbinned,iallocerr real :: area,csi print '(a,I4)', 'Carrying out radial binning, number of bins: ',nbins